1 /**
2 @file code.c
3 @author J. Marcel van der Veer
4 @brief Emit C code for Algol 68 constructs.
5 @section Copyright
6
7 This file is part of Algol68G - an Algol 68 compiler-interpreter.
8 Copyright 2001-2016 J. Marcel van der Veer <algol68g@xs4all.nl>.
9
10 @section License
11
12 This program is free software; you can redistribute it and/or modify it under
13 the terms of the GNU General Public License as published by the Free Software
14 Foundation; either version 3 of the License, or (at your option) any later
15 version.
16
17 This program is distributed in the hope that it will be useful, but WITHOUT ANY
18 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
19 PARTICULAR PURPOSE. See the GNU General Public License for more details.
20
21 You should have received a copy of the GNU General Public License along with
22 this program. If not, see <http://www.gnu.org/licenses/>.
23
24 @section Description
25
26 This file generates optimised C routines for many units in an Algol 68 source
27 program. A68G 1.x contained some general optimised routines. These are
28 decommissioned in A68G 2.x that dynamically generates routines depending
29 on the source code. The generated routines are compiled on the fly into a dynamic
30 library that is linked by the running interpreter.
31 To invoke this code generator specify option --optimise.
32 Currently the optimiser only considers units that operate on basic modes that are
33 contained in a single C struct, for instance primitive modes
34
35 INT, REAL, BOOL, CHAR and BITS
36
37 and simple structures of these basic modes, such as
38
39 COMPLEX
40
41 and also (single) references, rows and procedures
42
43 REF MODE, [] MODE, PROC PARAMSETY MODE
44
45 The code generator employs a few simple optimisations like constant folding
46 and common subexpression elimination when DEREFERENCING or SLICING is
47 performed; for instance
48
49 x[i + 1] := x[i + 1] + 1
50
51 translates into
52
53 tmp = x[i + 1]; tmp := tmp + 1
54
55 There are no optimisations that are easily recognised by the back end compiler,
56 for instance symbolic simplification.
57
58 You will find here and there lines
59
60 if (DEBUG_LEVEL >= ...)
61
62 which I use to debug the compiler - MvdV.
63 1: denotations only
64 2: also basic unit compilation
65 3: also better fetching of data from the stack
66 4: also compile enclosed clauses
67 Below definition switches everything on:
68 #define DEBUG_LEVEL 9
69 **/
70
71 #define DEBUG_LEVEL 9
72
73 #if defined HAVE_CONFIG_H
74 #include "a68g-config.h"
75 #endif
76
77 #include "a68g.h"
78
79 #define BASIC(p, n) (basic_unit (locate ((p), (n))))
80
81 #define CON "_const"
82 #define ELM "_elem"
83 #define TMP "_tmp"
84 #define ARG "_arg"
85 #define ARR "_array"
86 #define DEC "_declarer"
87 #define DRF "_deref"
88 #define DSP "_display"
89 #define FUN "_function"
90 #define PUP "_pop"
91 #define REF "_ref"
92 #define SEL "_field"
93 #define TUP "_tuple"
94
95 #define A68_MAKE_NOTHING 0
96 #define A68_MAKE_OTHERS 1
97 #define A68_MAKE_FUNCTION 2
98
99 #define OFFSET_OFF(s) (OFFSET (NODE_PACK (SUB (s))))
100 #define LONG_MODE(m) ((m) == MODE (LONG_INT) || (m) == MODE (LONG_REAL))
101 #define WIDEN_TO(p, a, b) (MOID (p) == MODE (b) && MOID (SUB (p)) == MODE (a))
102
103 #define GC_MODE(m) (m != NO_MOID && (IS (m, REF_SYMBOL) || IS (DEFLEX (m), ROW_SYMBOL)))
104 #define NEEDS_DNS(m) (m != NO_MOID && (IS (m, REF_SYMBOL) || IS (m, PROC_SYMBOL) || IS (m, UNION_SYMBOL) || IS (m, FORMAT_SYMBOL)))
105
106 #define CODE_EXECUTE(p) {\
107 indentf (out, snprintf (line, SNPRINTF_SIZE, "EXECUTE_UNIT_TRACE (_N_ (%d));", NUMBER (p)));\
108 }
109
110 #define NAME_SIZE 128
111
112 static BOOL_T long_mode_allowed = A68_TRUE;
113
114 static int indentation = 0;
115 static char line[BUFFER_SIZE];
116
117 static BOOL_T basic_unit (NODE_T *);
118 static char *compile_unit (NODE_T *, FILE_T, BOOL_T);
119 static void inline_unit (NODE_T *, FILE_T, int);
120 static void compile_units (NODE_T *, FILE_T);
121 static void indent (FILE_T, char *);
122 static void indentf (FILE_T, int);
123
124 /* The phases we go through */
125 enum
126 { L_NONE = 0, L_DECLARE = 1, L_INITIALISE, L_EXECUTE, L_EXECUTE_2, L_YIELD, L_PUSH };
127
128 /*********************************************************/
129 /* TRANSLATION tabulates translations for genie actions. */
130 /* This tells what to call for an A68 action. */
131 /*********************************************************/
132
133 typedef int LEVEL_T;
134 typedef struct
135 {
136 GPROC *procedure;
137 char *code;
138 } TRANSLATION;
139
140 static TRANSLATION monadics[] = {
141 {genie_minus_int, "-"},
142 {genie_minus_real, "-"},
143 {genie_abs_int, "labs"},
144 {genie_abs_real, "fabs"},
145 {genie_sign_int, "SIGN"},
146 {genie_sign_real, "SIGN"},
147 {genie_entier_real, "a68g_entier"},
148 {genie_round_real, "a68g_round"},
149 {genie_not_bool, "!"},
150 {genie_abs_bool, "(int) "},
151 {genie_abs_bits, "(int) "},
152 {genie_bin_int, "(unsigned) "},
153 {genie_not_bits, "~"},
154 {genie_abs_char, "TO_UCHAR"},
155 {genie_repr_char, ""},
156 {genie_re_complex, "a68g_re_complex"},
157 {genie_im_complex, "a68g_im_complex"},
158 {genie_minus_complex, "a68g_minus_complex"},
159 {genie_abs_complex, "a68g_abs_complex"},
160 {genie_arg_complex, "a68g_arg_complex"},
161 {genie_conj_complex, "a68g_conj_complex"},
162 {genie_round_long_mp, "(void) round_mp"},
163 {genie_entier_long_mp, "(void) entier_mp"},
164 {genie_minus_long_mp, "(void) minus_mp"},
165 {genie_abs_long_mp, "(void) abs_mp"},
166 {genie_idle, ""},
167 {NO_GPROC, NO_TEXT}
168 };
169
170 static TRANSLATION dyadics[] = {
171 {genie_add_int, "+"},
172 {genie_sub_int, "-"},
173 {genie_mul_int, "*"},
174 {genie_over_int, "/"},
175 {genie_mod_int, "a68g_mod_int"},
176 {genie_div_int, "DIV_INT"},
177 {genie_eq_int, "=="},
178 {genie_ne_int, "!="},
179 {genie_lt_int, "<"},
180 {genie_gt_int, ">"},
181 {genie_le_int, "<="},
182 {genie_ge_int, ">="},
183 {genie_plusab_int, "a68g_plusab_int"},
184 {genie_minusab_int, "a68g_minusab_int"},
185 {genie_timesab_int, "a68g_timesab_int"},
186 {genie_overab_int, "a68g_overab_int"},
187 {genie_add_real, "+"},
188 {genie_sub_real, "-"},
189 {genie_mul_real, "*"},
190 {genie_div_real, "/"},
191 {genie_pow_real, "a68g_pow_real"},
192 {genie_pow_real_int, "a68g_pow_real_int"},
193 {genie_eq_real, "=="},
194 {genie_ne_real, "!="},
195 {genie_lt_real, "<"},
196 {genie_gt_real, ">"},
197 {genie_le_real, "<="},
198 {genie_ge_real, ">="},
199 {genie_plusab_real, "a68g_plusab_real"},
200 {genie_minusab_real, "a68g_minusab_real"},
201 {genie_timesab_real, "a68g_timesab_real"},
202 {genie_divab_real, "a68g_divab_real"},
203 {genie_eq_char, "=="},
204 {genie_ne_char, "!="},
205 {genie_lt_char, "<"},
206 {genie_gt_char, ">"},
207 {genie_le_char, "<="},
208 {genie_ge_char, ">="},
209 {genie_eq_bool, "=="},
210 {genie_ne_bool, "!="},
211 {genie_and_bool, "&&"},
212 {genie_or_bool, "||"},
213 {genie_and_bits, "&"},
214 {genie_or_bits, "|"},
215 {genie_eq_bits, "=="},
216 {genie_ne_bits, "!="},
217 {genie_shl_bits, "<<"},
218 {genie_shr_bits, ">>"},
219 {genie_icomplex, "a68g_i_complex"},
220 {genie_iint_complex, "a68g_i_complex"},
221 {genie_abs_complex, "a68g_abs_complex"},
222 {genie_arg_complex, "a68g_arg_complex"},
223 {genie_add_complex, "a68g_add_complex"},
224 {genie_sub_complex, "a68g_sub_complex"},
225 {genie_mul_complex, "a68g_mul_complex"},
226 {genie_div_complex, "a68g_div_complex"},
227 {genie_eq_complex, "a68g_eq_complex"},
228 {genie_ne_complex, "a68g_ne_complex"},
229 {genie_add_long_int, "(void) add_mp"},
230 {genie_add_long_mp, "(void) add_mp"},
231 {genie_sub_long_int, "(void) sub_mp"},
232 {genie_sub_long_mp, "(void) sub_mp"},
233 {genie_mul_long_int, "(void) mul_mp"},
234 {genie_mul_long_mp, "(void) mul_mp"},
235 {genie_over_long_mp, "(void) over_mp"},
236 {genie_div_long_mp, "(void) div_mp"},
237 {genie_eq_long_mp, "eq_mp"},
238 {genie_ne_long_mp, "ne_mp"},
239 {genie_lt_long_mp, "lt_mp"},
240 {genie_le_long_mp, "le_mp"},
241 {genie_gt_long_mp, "gt_mp"},
242 {genie_ge_long_mp, "ge_mp"},
243 {NO_GPROC, NO_TEXT}
244 };
245
246 static TRANSLATION functions[] = {
247 {genie_sqrt_real, "sqrt"},
248 {genie_curt_real, "curt"},
249 {genie_exp_real, "a68g_exp"},
250 {genie_ln_real, "log"},
251 {genie_log_real, "log10"},
252 {genie_sin_real, "sin"},
253 {genie_cos_real, "cos"},
254 {genie_tan_real, "tan"},
255 {genie_arcsin_real, "asin"},
256 {genie_arccos_real, "acos"},
257 {genie_arctan_real, "atan"},
258 {genie_sinh_real, "sinh"},
259 {genie_cosh_real, "cosh"},
260 {genie_tanh_real, "tanh"},
261 {genie_arcsinh_real, "a68g_asinh"},
262 {genie_arccosh_real, "a68g_acosh"},
263 {genie_arctanh_real, "a68g_atanh"},
264 {genie_inverf_real, "inverf"},
265 {genie_inverfc_real, "inverfc"},
266 {genie_sqrt_complex, "a68g_sqrt_complex"},
267 {genie_exp_complex, "a68g_exp_complex"},
268 {genie_ln_complex, "a68g_ln_complex"},
269 {genie_sin_complex, "a68g_sin_complex"},
270 {genie_cos_complex, "a68g_cos_complex"},
271 {genie_tan_complex, "a68g_tan_complex"},
272 {genie_arcsin_complex, "a68g_arcsin_complex"},
273 {genie_arccos_complex, "a68g_arccos_complex"},
274 {genie_arctan_complex, "a68g_arctan_complex"},
275 {genie_sqrt_long_mp, "(void) sqrt_mp"},
276 {genie_exp_long_mp, "(void) exp_mp"},
277 {genie_ln_long_mp, "(void) ln_mp"},
278 {genie_log_long_mp, "(void) log_mp"},
279 {genie_sin_long_mp, "(void) sin_mp"},
280 {genie_cos_long_mp, "(void) cos_mp"},
281 {genie_tan_long_mp, "(void) tan_mp"},
282 {genie_asin_long_mp, "(void) asin_mp"},
283 {genie_acos_long_mp, "(void) acos_mp"},
284 {genie_atan_long_mp, "(void) atan_mp"},
285 {genie_sinh_long_mp, "(void) sinh_mp"},
286 {genie_cosh_long_mp, "(void) cosh_mp"},
287 {genie_tanh_long_mp, "(void) tanh_mp"},
288 {genie_arcsinh_long_mp, "(void) asinh_mp"},
289 {genie_arccosh_long_mp, "(void) acosh_mp"},
290 {genie_arctanh_long_mp, "(void) atanh_mp"},
291 {NO_GPROC, NO_TEXT}
292 };
293
294 static TRANSLATION constants[] = {
295 {genie_int_lengths, "3"},
296 {genie_int_shorths, "1"},
297 {genie_real_lengths, "3"},
298 {genie_real_shorths, "1"},
299 {genie_complex_lengths, "3"},
300 {genie_complex_shorths, "1"},
301 {genie_bits_lengths, "3"},
302 {genie_bits_shorths, "1"},
303 {genie_bytes_lengths, "2"},
304 {genie_bytes_shorths, "1"},
305 {genie_int_width, "INT_WIDTH"},
306 {genie_long_int_width, "LONG_INT_WIDTH"},
307 {genie_longlong_int_width, "LONGLONG_INT_WIDTH"},
308 {genie_real_width, "REAL_WIDTH"},
309 {genie_long_real_width, "LONG_REAL_WIDTH"},
310 {genie_longlong_real_width, "LONGLONG_REAL_WIDTH"},
311 {genie_exp_width, "EXP_WIDTH"},
312 {genie_long_exp_width, "LONG_EXP_WIDTH"},
313 {genie_longlong_exp_width, "LONGLONG_EXP_WIDTH"},
314 {genie_bits_width, "BITS_WIDTH"},
315 {genie_bytes_width, "BYTES_WIDTH"},
316 {genie_long_bytes_width, "LONG_BYTES_WIDTH"},
317 {genie_max_abs_char, "UCHAR_MAX"},
318 {genie_max_int, "A68_MAX_INT"},
319 {genie_max_real, "DBL_MAX"},
320 {genie_min_real, "DBL_MIN"},
321 {genie_null_char, "NULL_CHAR"},
322 {genie_small_real, "DBL_EPSILON"},
323 {genie_pi, "A68_PI"},
324 {genie_pi_long_mp, NO_TEXT},
325 {genie_long_max_int, NO_TEXT},
326 {genie_long_min_real, NO_TEXT},
327 {genie_long_small_real, NO_TEXT},
328 {genie_long_max_real, NO_TEXT},
329 {genie_cgs_acre, "GSL_CONST_CGSM_ACRE"},
330 {genie_cgs_angstrom, "GSL_CONST_CGSM_ANGSTROM"},
331 {genie_cgs_astronomical_unit, "GSL_CONST_CGSM_ASTRONOMICAL_UNIT"},
332 {genie_cgs_bar, "GSL_CONST_CGSM_BAR"},
333 {genie_cgs_barn, "GSL_CONST_CGSM_BARN"},
334 {genie_cgs_bohr_magneton, "GSL_CONST_CGSM_BOHR_MAGNETON"},
335 {genie_cgs_bohr_radius, "GSL_CONST_CGSM_BOHR_RADIUS"},
336 {genie_cgs_boltzmann, "GSL_CONST_CGSM_BOLTZMANN"},
337 {genie_cgs_btu, "GSL_CONST_CGSM_BTU"},
338 {genie_cgs_calorie, "GSL_CONST_CGSM_CALORIE"},
339 {genie_cgs_canadian_gallon, "GSL_CONST_CGSM_CANADIAN_GALLON"},
340 {genie_cgs_carat, "GSL_CONST_CGSM_CARAT"},
341 {genie_cgs_cup, "GSL_CONST_CGSM_CUP"},
342 {genie_cgs_curie, "GSL_CONST_CGSM_CURIE"},
343 {genie_cgs_day, "GSL_CONST_CGSM_DAY"},
344 {genie_cgs_dyne, "GSL_CONST_CGSM_DYNE"},
345 {genie_cgs_electron_charge, "GSL_CONST_CGSM_ELECTRON_CHARGE"},
346 {genie_cgs_electron_magnetic_moment, "GSL_CONST_CGSM_ELECTRON_MAGNETIC_MOMENT"},
347 {genie_cgs_electron_volt, "GSL_CONST_CGSM_ELECTRON_VOLT"},
348 {genie_cgs_erg, "GSL_CONST_CGSM_ERG"},
349 {genie_cgs_faraday, "GSL_CONST_CGSM_FARADAY"},
350 {genie_cgs_fathom, "GSL_CONST_CGSM_FATHOM"},
351 {genie_cgs_fluid_ounce, "GSL_CONST_CGSM_FLUID_OUNCE"},
352 {genie_cgs_foot, "GSL_CONST_CGSM_FOOT"},
353 {genie_cgs_footcandle, "GSL_CONST_CGSM_FOOTCANDLE"},
354 {genie_cgs_footlambert, "GSL_CONST_CGSM_FOOTLAMBERT"},
355 {genie_cgs_gauss, "GSL_CONST_CGSM_GAUSS"},
356 {genie_cgs_gram_force, "GSL_CONST_CGSM_GRAM_FORCE"},
357 {genie_cgs_grav_accel, "GSL_CONST_CGSM_GRAV_ACCEL"},
358 {genie_cgs_gravitational_constant, "GSL_CONST_CGSM_GRAVITATIONAL_CONSTANT"},
359 {genie_cgs_hectare, "GSL_CONST_CGSM_HECTARE"},
360 {genie_cgs_horsepower, "GSL_CONST_CGSM_HORSEPOWER"},
361 {genie_cgs_hour, "GSL_CONST_CGSM_HOUR"},
362 {genie_cgs_inch, "GSL_CONST_CGSM_INCH"},
363 {genie_cgs_inch_of_mercury, "GSL_CONST_CGSM_INCH_OF_MERCURY"},
364 {genie_cgs_inch_of_water, "GSL_CONST_CGSM_INCH_OF_WATER"},
365 {genie_cgs_joule, "GSL_CONST_CGSM_JOULE"},
366 {genie_cgs_kilometers_per_hour, "GSL_CONST_CGSM_KILOMETERS_PER_HOUR"},
367 {genie_cgs_kilopound_force, "GSL_CONST_CGSM_KILOPOUND_FORCE"},
368 {genie_cgs_knot, "GSL_CONST_CGSM_KNOT"},
369 {genie_cgs_lambert, "GSL_CONST_CGSM_LAMBERT"},
370 {genie_cgs_light_year, "GSL_CONST_CGSM_LIGHT_YEAR"},
371 {genie_cgs_liter, "GSL_CONST_CGSM_LITER"},
372 {genie_cgs_lumen, "GSL_CONST_CGSM_LUMEN"},
373 {genie_cgs_lux, "GSL_CONST_CGSM_LUX"},
374 {genie_cgs_mass_electron, "GSL_CONST_CGSM_MASS_ELECTRON"},
375 {genie_cgs_mass_muon, "GSL_CONST_CGSM_MASS_MUON"},
376 {genie_cgs_mass_neutron, "GSL_CONST_CGSM_MASS_NEUTRON"},
377 {genie_cgs_mass_proton, "GSL_CONST_CGSM_MASS_PROTON"},
378 {genie_cgs_meter_of_mercury, "GSL_CONST_CGSM_METER_OF_MERCURY"},
379 {genie_cgs_metric_ton, "GSL_CONST_CGSM_METRIC_TON"},
380 {genie_cgs_micron, "GSL_CONST_CGSM_MICRON"},
381 {genie_cgs_mil, "GSL_CONST_CGSM_MIL"},
382 {genie_cgs_mile, "GSL_CONST_CGSM_MILE"},
383 {genie_cgs_miles_per_hour, "GSL_CONST_CGSM_MILES_PER_HOUR"},
384 {genie_cgs_minute, "GSL_CONST_CGSM_MINUTE"},
385 {genie_cgs_molar_gas, "GSL_CONST_CGSM_MOLAR_GAS"},
386 {genie_cgs_nautical_mile, "GSL_CONST_CGSM_NAUTICAL_MILE"},
387 {genie_cgs_newton, "GSL_CONST_CGSM_NEWTON"},
388 {genie_cgs_nuclear_magneton, "GSL_CONST_CGSM_NUCLEAR_MAGNETON"},
389 {genie_cgs_ounce_mass, "GSL_CONST_CGSM_OUNCE_MASS"},
390 {genie_cgs_parsec, "GSL_CONST_CGSM_PARSEC"},
391 {genie_cgs_phot, "GSL_CONST_CGSM_PHOT"},
392 {genie_cgs_pint, "GSL_CONST_CGSM_PINT"},
393 {genie_cgs_planck_constant_h, "6.6260693e-27"},
394 {genie_cgs_planck_constant_hbar, "1.0545717e-27"},
395 {genie_cgs_point, "GSL_CONST_CGSM_POINT"},
396 {genie_cgs_poise, "GSL_CONST_CGSM_POISE"},
397 {genie_cgs_pound_force, "GSL_CONST_CGSM_POUND_FORCE"},
398 {genie_cgs_pound_mass, "GSL_CONST_CGSM_POUND_MASS"},
399 {genie_cgs_poundal, "GSL_CONST_CGSM_POUNDAL"},
400 {genie_cgs_proton_magnetic_moment, "GSL_CONST_CGSM_PROTON_MAGNETIC_MOMENT"},
401 {genie_cgs_psi, "GSL_CONST_CGSM_PSI"},
402 {genie_cgs_quart, "GSL_CONST_CGSM_QUART"},
403 {genie_cgs_rad, "GSL_CONST_CGSM_RAD"},
404 {genie_cgs_roentgen, "GSL_CONST_CGSM_ROENTGEN"},
405 {genie_cgs_rydberg, "GSL_CONST_CGSM_RYDBERG"},
406 {genie_cgs_solar_mass, "GSL_CONST_CGSM_SOLAR_MASS"},
407 {genie_cgs_speed_of_light, "GSL_CONST_CGSM_SPEED_OF_LIGHT"},
408 {genie_cgs_standard_gas_volume, "GSL_CONST_CGSM_STANDARD_GAS_VOLUME"},
409 {genie_cgs_std_atmosphere, "GSL_CONST_CGSM_STD_ATMOSPHERE"},
410 {genie_cgs_stilb, "GSL_CONST_CGSM_STILB"},
411 {genie_cgs_stokes, "GSL_CONST_CGSM_STOKES"},
412 {genie_cgs_tablespoon, "GSL_CONST_CGSM_TABLESPOON"},
413 {genie_cgs_teaspoon, "GSL_CONST_CGSM_TEASPOON"},
414 {genie_cgs_texpoint, "GSL_CONST_CGSM_TEXPOINT"},
415 {genie_cgs_therm, "GSL_CONST_CGSM_THERM"},
416 {genie_cgs_ton, "GSL_CONST_CGSM_TON"},
417 {genie_cgs_torr, "GSL_CONST_CGSM_TORR"},
418 {genie_cgs_troy_ounce, "GSL_CONST_CGSM_TROY_OUNCE"},
419 {genie_cgs_uk_gallon, "GSL_CONST_CGSM_UK_GALLON"},
420 {genie_cgs_uk_ton, "GSL_CONST_CGSM_UK_TON"},
421 {genie_cgs_unified_atomic_mass, "GSL_CONST_CGSM_UNIFIED_ATOMIC_MASS"},
422 {genie_cgs_us_gallon, "GSL_CONST_CGSM_US_GALLON"},
423 {genie_cgs_week, "GSL_CONST_CGSM_WEEK"},
424 {genie_cgs_yard, "GSL_CONST_CGSM_YARD"},
425 {genie_mks_acre, "GSL_CONST_MKS_ACRE"},
426 {genie_mks_angstrom, "GSL_CONST_MKS_ANGSTROM"},
427 {genie_mks_astronomical_unit, "GSL_CONST_MKS_ASTRONOMICAL_UNIT"},
428 {genie_mks_bar, "GSL_CONST_MKS_BAR"},
429 {genie_mks_barn, "GSL_CONST_MKS_BARN"},
430 {genie_mks_bohr_magneton, "GSL_CONST_MKS_BOHR_MAGNETON"},
431 {genie_mks_bohr_radius, "GSL_CONST_MKS_BOHR_RADIUS"},
432 {genie_mks_boltzmann, "GSL_CONST_MKS_BOLTZMANN"},
433 {genie_mks_btu, "GSL_CONST_MKS_BTU"},
434 {genie_mks_calorie, "GSL_CONST_MKS_CALORIE"},
435 {genie_mks_canadian_gallon, "GSL_CONST_MKS_CANADIAN_GALLON"},
436 {genie_mks_carat, "GSL_CONST_MKS_CARAT"},
437 {genie_mks_cup, "GSL_CONST_MKS_CUP"},
438 {genie_mks_curie, "GSL_CONST_MKS_CURIE"},
439 {genie_mks_day, "GSL_CONST_MKS_DAY"},
440 {genie_mks_dyne, "GSL_CONST_MKS_DYNE"},
441 {genie_mks_electron_charge, "GSL_CONST_MKS_ELECTRON_CHARGE"},
442 {genie_mks_electron_magnetic_moment, "GSL_CONST_MKS_ELECTRON_MAGNETIC_MOMENT"},
443 {genie_mks_electron_volt, "GSL_CONST_MKS_ELECTRON_VOLT"},
444 {genie_mks_erg, "GSL_CONST_MKS_ERG"},
445 {genie_mks_faraday, "GSL_CONST_MKS_FARADAY"},
446 {genie_mks_fathom, "GSL_CONST_MKS_FATHOM"},
447 {genie_mks_fluid_ounce, "GSL_CONST_MKS_FLUID_OUNCE"},
448 {genie_mks_foot, "GSL_CONST_MKS_FOOT"},
449 {genie_mks_footcandle, "GSL_CONST_MKS_FOOTCANDLE"},
450 {genie_mks_footlambert, "GSL_CONST_MKS_FOOTLAMBERT"},
451 {genie_mks_gauss, "GSL_CONST_MKS_GAUSS"},
452 {genie_mks_gram_force, "GSL_CONST_MKS_GRAM_FORCE"},
453 {genie_mks_grav_accel, "GSL_CONST_MKS_GRAV_ACCEL"},
454 {genie_mks_gravitational_constant, "GSL_CONST_MKS_GRAVITATIONAL_CONSTANT"},
455 {genie_mks_hectare, "GSL_CONST_MKS_HECTARE"},
456 {genie_mks_horsepower, "GSL_CONST_MKS_HORSEPOWER"},
457 {genie_mks_hour, "GSL_CONST_MKS_HOUR"},
458 {genie_mks_inch, "GSL_CONST_MKS_INCH"},
459 {genie_mks_inch_of_mercury, "GSL_CONST_MKS_INCH_OF_MERCURY"},
460 {genie_mks_inch_of_water, "GSL_CONST_MKS_INCH_OF_WATER"},
461 {genie_mks_joule, "GSL_CONST_MKS_JOULE"},
462 {genie_mks_kilometers_per_hour, "GSL_CONST_MKS_KILOMETERS_PER_HOUR"},
463 {genie_mks_kilopound_force, "GSL_CONST_MKS_KILOPOUND_FORCE"},
464 {genie_mks_knot, "GSL_CONST_MKS_KNOT"},
465 {genie_mks_lambert, "GSL_CONST_MKS_LAMBERT"},
466 {genie_mks_light_year, "GSL_CONST_MKS_LIGHT_YEAR"},
467 {genie_mks_liter, "GSL_CONST_MKS_LITER"},
468 {genie_mks_lumen, "GSL_CONST_MKS_LUMEN"},
469 {genie_mks_lux, "GSL_CONST_MKS_LUX"},
470 {genie_mks_mass_electron, "GSL_CONST_MKS_MASS_ELECTRON"},
471 {genie_mks_mass_muon, "GSL_CONST_MKS_MASS_MUON"},
472 {genie_mks_mass_neutron, "GSL_CONST_MKS_MASS_NEUTRON"},
473 {genie_mks_mass_proton, "GSL_CONST_MKS_MASS_PROTON"},
474 {genie_mks_meter_of_mercury, "GSL_CONST_MKS_METER_OF_MERCURY"},
475 {genie_mks_metric_ton, "GSL_CONST_MKS_METRIC_TON"},
476 {genie_mks_micron, "GSL_CONST_MKS_MICRON"},
477 {genie_mks_mil, "GSL_CONST_MKS_MIL"},
478 {genie_mks_mile, "GSL_CONST_MKS_MILE"},
479 {genie_mks_miles_per_hour, "GSL_CONST_MKS_MILES_PER_HOUR"},
480 {genie_mks_minute, "GSL_CONST_MKS_MINUTE"},
481 {genie_mks_molar_gas, "GSL_CONST_MKS_MOLAR_GAS"},
482 {genie_mks_nautical_mile, "GSL_CONST_MKS_NAUTICAL_MILE"},
483 {genie_mks_newton, "GSL_CONST_MKS_NEWTON"},
484 {genie_mks_nuclear_magneton, "GSL_CONST_MKS_NUCLEAR_MAGNETON"},
485 {genie_mks_ounce_mass, "GSL_CONST_MKS_OUNCE_MASS"},
486 {genie_mks_parsec, "GSL_CONST_MKS_PARSEC"},
487 {genie_mks_phot, "GSL_CONST_MKS_PHOT"},
488 {genie_mks_pint, "GSL_CONST_MKS_PINT"},
489 {genie_mks_planck_constant_h, "6.6260693e-34"},
490 {genie_mks_planck_constant_hbar, "1.0545717e-34"},
491 {genie_mks_point, "GSL_CONST_MKS_POINT"},
492 {genie_mks_poise, "GSL_CONST_MKS_POISE"},
493 {genie_mks_pound_force, "GSL_CONST_MKS_POUND_FORCE"},
494 {genie_mks_pound_mass, "GSL_CONST_MKS_POUND_MASS"},
495 {genie_mks_poundal, "GSL_CONST_MKS_POUNDAL"},
496 {genie_mks_proton_magnetic_moment, "GSL_CONST_MKS_PROTON_MAGNETIC_MOMENT"},
497 {genie_mks_psi, "GSL_CONST_MKS_PSI"},
498 {genie_mks_quart, "GSL_CONST_MKS_QUART"},
499 {genie_mks_rad, "GSL_CONST_MKS_RAD"},
500 {genie_mks_roentgen, "GSL_CONST_MKS_ROENTGEN"},
501 {genie_mks_rydberg, "GSL_CONST_MKS_RYDBERG"},
502 {genie_mks_solar_mass, "GSL_CONST_MKS_SOLAR_MASS"},
503 {genie_mks_speed_of_light, "GSL_CONST_MKS_SPEED_OF_LIGHT"},
504 {genie_mks_standard_gas_volume, "GSL_CONST_MKS_STANDARD_GAS_VOLUME"},
505 {genie_mks_std_atmosphere, "GSL_CONST_MKS_STD_ATMOSPHERE"},
506 {genie_mks_stilb, "GSL_CONST_MKS_STILB"},
507 {genie_mks_stokes, "GSL_CONST_MKS_STOKES"},
508 {genie_mks_tablespoon, "GSL_CONST_MKS_TABLESPOON"},
509 {genie_mks_teaspoon, "GSL_CONST_MKS_TEASPOON"},
510 {genie_mks_texpoint, "GSL_CONST_MKS_TEXPOINT"},
511 {genie_mks_therm, "GSL_CONST_MKS_THERM"},
512 {genie_mks_ton, "GSL_CONST_MKS_TON"},
513 {genie_mks_torr, "GSL_CONST_MKS_TORR"},
514 {genie_mks_troy_ounce, "GSL_CONST_MKS_TROY_OUNCE"},
515 {genie_mks_uk_gallon, "GSL_CONST_MKS_UK_GALLON"},
516 {genie_mks_uk_ton, "GSL_CONST_MKS_UK_TON"},
517 {genie_mks_unified_atomic_mass, "GSL_CONST_MKS_UNIFIED_ATOMIC_MASS"},
518 {genie_mks_us_gallon, "GSL_CONST_MKS_US_GALLON"},
519 {genie_mks_vacuum_permeability, "GSL_CONST_MKS_VACUUM_PERMEABILITY"},
520 {genie_mks_vacuum_permittivity, "GSL_CONST_MKS_VACUUM_PERMITTIVITY"},
521 {genie_mks_week, "GSL_CONST_MKS_WEEK"},
522 {genie_mks_yard, "GSL_CONST_MKS_YARD"},
523 {genie_num_atto, "GSL_CONST_NUM_ATTO"},
524 {genie_num_avogadro, "GSL_CONST_NUM_AVOGADRO"},
525 {genie_num_exa, "GSL_CONST_NUM_EXA"},
526 {genie_num_femto, "GSL_CONST_NUM_FEMTO"},
527 {genie_num_fine_structure, "GSL_CONST_NUM_FINE_STRUCTURE"},
528 {genie_num_giga, "GSL_CONST_NUM_GIGA"},
529 {genie_num_kilo, "GSL_CONST_NUM_KILO"},
530 {genie_num_mega, "GSL_CONST_NUM_MEGA"},
531 {genie_num_micro, "GSL_CONST_NUM_MICRO"},
532 {genie_num_milli, "GSL_CONST_NUM_MILLI"},
533 {genie_num_nano, "GSL_CONST_NUM_NANO"},
534 {genie_num_peta, "GSL_CONST_NUM_PETA"},
535 {genie_num_pico, "GSL_CONST_NUM_PICO"},
536 {genie_num_tera, "GSL_CONST_NUM_TERA"},
537 {genie_num_yocto, "GSL_CONST_NUM_YOCTO"},
538 {genie_num_yotta, "GSL_CONST_NUM_YOTTA"},
539 {genie_num_zepto, "GSL_CONST_NUM_ZEPTO"},
540 {genie_num_zetta, "GSL_CONST_NUM_ZETTA"},
541 {NO_GPROC, NO_TEXT}
542 };
543
544 /**************************/
545 /* Pretty printing stuff. */
546 /**************************/
547
548 /**
549 @brief Write indented text.
550 @param out Output file descriptor.
551 @param str Text.
552 **/
553
554 static void
indent(FILE_T out,char * str)555 indent (FILE_T out, char *str)
556 {
557 int j = indentation;
558 if (out == 0) {
559 return;
560 }
561 while (j-- > 0) {
562 WRITE (out, " ");
563 }
564 WRITE (out, str);
565 }
566
567 /**
568 @brief Write unindented text.
569 @param out Output file descriptor.
570 @param str Text.
571 **/
572
573 static void
undent(FILE_T out,char * str)574 undent (FILE_T out, char *str)
575 {
576 if (out == 0) {
577 return;
578 }
579 WRITE (out, str);
580 }
581
582 /**
583 @brief Write indent text.
584 @param out Output file descriptor.
585 @param ret Bytes written by snprintf.
586 **/
587
588 static void
indentf(FILE_T out,int ret)589 indentf (FILE_T out, int ret)
590 {
591 if (out == 0) {
592 return;
593 }
594 if (ret >= 0) {
595 indent (out, line);
596 } else {
597 ABEND (A68_TRUE, "Return value failure", error_specification ());
598 }
599 }
600
601 /**
602 @brief Write unindent text.
603 @param out Output file descriptor.
604 @param ret Bytes written by snprintf.
605 **/
606
607 static void
undentf(FILE_T out,int ret)608 undentf (FILE_T out, int ret)
609 {
610 if (out == 0) {
611 return;
612 }
613 if (ret >= 0) {
614 WRITE (out, line);
615 } else {
616 ABEND (A68_TRUE, "Return value failure", error_specification ());
617 }
618 }
619
620 /*************************************/
621 /* Administration of C declarations */
622 /* Pretty printing of C declarations */
623 /*************************************/
624
625 /**
626 @brief Add declaration to a tree.
627 @param p Top token.
628 @param t Token text.
629 @return New entry.
630 **/
631
632 typedef struct DEC_T DEC_T;
633
634 struct DEC_T
635 {
636 char *text;
637 int level;
638 DEC_T *sub, *less, *more;
639 };
640
641 static DEC_T *root_idf = NO_DEC;
642
643 /**
644 @brief Add declaration to a tree.
645 @param p Top declaration.
646 @param level Pointer level (0, 1 = *, 2 = **, etcetera)
647 @param idf Identifier name.
648 @return New entry.
649 **/
650
651 DEC_T *
add_identifier(DEC_T ** p,int level,char * idf)652 add_identifier (DEC_T ** p, int level, char *idf)
653 {
654 char *z = new_temp_string (idf);
655 while (*p != NO_DEC) {
656 int k = strcmp (z, TEXT (*p));
657 if (k < 0) {
658 p = &LESS (*p);
659 } else if (k > 0) {
660 p = &MORE (*p);
661 } else {
662 ABEND (A68_TRUE, "duplicate declaration", z);
663 return (*p);
664 }
665 }
666 *p = (DEC_T *) get_temp_heap_space ((size_t) SIZE_AL (DEC_T));
667 TEXT (*p) = z;
668 LEVEL (*p) = level;
669 SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC;
670 return (*p);
671 }
672
673 /**
674 @brief Add declaration to a tree.
675 @param p Top declaration.
676 @param mode Mode for identifier.
677 @param level Pointer level (0, 1 = *, 2 = **, etcetera)
678 @param idf Identifier name.
679 @return New entry.
680 **/
681
682 DEC_T *
add_declaration(DEC_T ** p,char * mode,int level,char * idf)683 add_declaration (DEC_T ** p, char *mode, int level, char *idf)
684 {
685 char *z = new_temp_string (mode);
686 while (*p != NO_DEC) {
687 int k = strcmp (z, TEXT (*p));
688 if (k < 0) {
689 p = &LESS (*p);
690 } else if (k > 0) {
691 p = &MORE (*p);
692 } else {
693 (void) add_identifier (&SUB (*p), level, idf);
694 return (*p);
695 }
696 }
697 *p = (DEC_T *) get_temp_heap_space ((size_t) SIZE_AL (DEC_T));
698 TEXT (*p) = z;
699 LEVEL (*p) = -1;
700 SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC;
701 (void) add_identifier (&SUB (*p), level, idf);
702 return (*p);
703 }
704
705 static BOOL_T put_idf_comma = A68_TRUE;
706
707 /**
708 @brief Print identifiers (following mode).
709 @param out File to print to.
710 @param p Top token.
711 **/
712
713 void
print_identifiers(FILE_T out,DEC_T * p)714 print_identifiers (FILE_T out, DEC_T * p)
715 {
716 if (p != NO_DEC) {
717 print_identifiers (out, LESS (p));
718 if (put_idf_comma) {
719 WRITE (out, ", ");
720 } else {
721 put_idf_comma = A68_TRUE;
722 }
723 if (LEVEL (p) > 0) {
724 int k = LEVEL (p);
725 while (k--) {
726 WRITE (out, "*");
727 }
728 WRITE (out, " ");
729 }
730 WRITE (out, TEXT (p));
731 print_identifiers (out, MORE (p));
732 }
733 }
734
735 /**
736 @brief Print declarations.
737 @param out File to print to.
738 @param p Top token.
739 **/
740
741 void
print_declarations(FILE_T out,DEC_T * p)742 print_declarations (FILE_T out, DEC_T * p)
743 {
744 if (p != NO_DEC) {
745 print_declarations (out, LESS (p));
746 indent (out, TEXT (p));
747 WRITE (out, " ");
748 put_idf_comma = A68_FALSE;
749 print_identifiers (out, SUB (p));
750 WRITELN (out, ";\n")
751 print_declarations (out, MORE (p));
752 }
753 }
754
755 /***************************************************************************/
756 /* Administration for common (sub) expression elimination. */
757 /* BOOK keeps track of already seen (temporary) variables and denotations. */
758 /***************************************************************************/
759
760 typedef struct
761 {
762 int action, phase;
763 char *idf;
764 void *info;
765 int number;
766 } BOOK_T;
767
768 enum
769 { BOOK_NONE = 0, BOOK_DECL, BOOK_INIT, BOOK_DEREF, BOOK_ARRAY, BOOK_COMPILE };
770
771 #define MAX_BOOK 1024
772
773 BOOK_T temp_book[MAX_BOOK];
774 int temp_book_pointer;
775
776 /**
777 @brief Book identifier to keep track of it for CSE.
778 @param action Some identification as L_DECLARE or DEREFERENCING.
779 @param phase Phase in which booking is made.
780 @param idf Identifier name.
781 @param info Identifier information.
782 @param number Unique identifying number.
783 **/
784
785 static void
sign_in(int action,int phase,char * idf,void * info,int number)786 sign_in (int action, int phase, char *idf, void *info, int number)
787 {
788 if (temp_book_pointer < MAX_BOOK) {
789 ACTION (&temp_book[temp_book_pointer]) = action;
790 PHASE (&temp_book[temp_book_pointer]) = phase;
791 IDF (&temp_book[temp_book_pointer]) = idf;
792 INFO (&temp_book[temp_book_pointer]) = info;
793 NUMBER (&temp_book[temp_book_pointer]) = number;
794 temp_book_pointer++;
795 }
796 }
797
798 /**
799 @brief Whether identifier is signed_in.
800 @param action Some identification as L_DECLARE or DEREFERENCING.
801 @param phase Phase in which booking is made.
802 @param idf Identifier name.
803 @return Number given to it.
804 **/
805
806 static BOOK_T *
signed_in(int action,int phase,char * idf)807 signed_in (int action, int phase, char *idf)
808 {
809 int k;
810 for (k = 0; k < temp_book_pointer; k++) {
811 if (IDF (&temp_book[k]) == idf && ACTION (&temp_book[k]) == action && PHASE (&temp_book[k]) >= phase) {
812 return (&(temp_book[k]));
813 }
814 }
815 return (NO_BOOK);
816 }
817
818 /**
819 @brief Make name.
820 @param buf Output buffer.
821 @param name Appropriate name.
822 @param tag Optional tag to name.
823 @param n Unique identifying number.
824 @return Output buffer.
825 **/
826
827 static char *
make_name(char * buf,char * name,char * tag,int n)828 make_name (char *buf, char *name, char *tag, int n)
829 {
830 if (strlen (tag) > 0) {
831 ASSERT (snprintf (buf, NAME_SIZE, "%s_%s_%d", name, tag, n) >= 0);
832 } else {
833 ASSERT (snprintf (buf, NAME_SIZE, "%s_%d", name, n) >= 0);
834 }
835 ABEND (strlen (buf) >= NAME_SIZE, "make name error", NO_TEXT);
836 return (buf);
837 }
838
839 /**
840 @brief Whether two sub-trees are the same Algol 68 construct.
841 @param l Left-hand tree.
842 @param r Right-hand tree.
843 @return See brief description.
844 **/
845
846 static BOOL_T
same_tree(NODE_T * l,NODE_T * r)847 same_tree (NODE_T * l, NODE_T * r)
848 {
849 if (l == NO_NODE) {
850 return ((BOOL_T) (r == NO_NODE));
851 } else if (r == NO_NODE) {
852 return ((BOOL_T) (l == NO_NODE));
853 } else if (ATTRIBUTE (l) == ATTRIBUTE (r) && NSYMBOL (l) == NSYMBOL (r)) {
854 return ((BOOL_T) (same_tree (SUB (l), SUB (r)) && same_tree (NEXT (l), NEXT (r))));
855 } else {
856 return (A68_FALSE);
857 }
858 }
859
860
861 /********************/
862 /* Basic mode check */
863 /********************/
864
865 /**
866 @brief Whether primitive mode, with simple C equivalent.
867 @param m Mode to check.
868 @return See brief description.
869 **/
870
871 static BOOL_T
primitive_mode(MOID_T * m)872 primitive_mode (MOID_T * m)
873 {
874 if (m == MODE (INT)) {
875 return (A68_TRUE);
876 } else if (m == MODE (REAL)) {
877 return (A68_TRUE);
878 } else if (m == MODE (BOOL)) {
879 return (A68_TRUE);
880 } else if (m == MODE (CHAR)) {
881 return (A68_TRUE);
882 } else if (m == MODE (BITS)) {
883 return (A68_TRUE);
884 } else {
885 return (A68_FALSE);
886 }
887 }
888
889 /**
890 @brief Whether mode for which denotations are compiled.
891 @param m Mode to check.
892 @return See brief description.
893 **/
894
895 static BOOL_T
denotation_mode(MOID_T * m)896 denotation_mode (MOID_T * m)
897 {
898 if (primitive_mode (m)) {
899 return (A68_TRUE);
900 } else if (LONG_MODE (m) && long_mode_allowed) {
901 return (A68_TRUE);
902 } else {
903 return (A68_FALSE);
904 }
905 }
906
907 /**
908 @brief Whether mode is handled by the constant folder.
909 @param m Mode to check.
910 @return See brief description.
911 **/
912
913 BOOL_T
folder_mode(MOID_T * m)914 folder_mode (MOID_T * m)
915 {
916 if (primitive_mode (m)) {
917 return (A68_TRUE);
918 } else if (m == MODE (COMPLEX)) {
919 return (A68_TRUE);
920 } else if (LONG_MODE (m)) {
921 return (A68_TRUE);
922 } else {
923 return (A68_FALSE);
924 }
925 }
926
927 /**
928 @brief Whether basic mode, for which units are compiled.
929 @param m Mode to check.
930 @return See brief description.
931 **/
932
933 static BOOL_T
basic_mode(MOID_T * m)934 basic_mode (MOID_T * m)
935 {
936 if (denotation_mode (m)) {
937 return (A68_TRUE);
938 } else if (IS (m, REF_SYMBOL)) {
939 if (IS (SUB (m), REF_SYMBOL) || IS (SUB (m), PROC_SYMBOL)) {
940 return (A68_FALSE);
941 } else {
942 return (basic_mode (SUB (m)));
943 }
944 } else if (IS (m, ROW_SYMBOL)) {
945 if (primitive_mode (SUB (m))) {
946 return (A68_TRUE);
947 } else if (IS (SUB (m), STRUCT_SYMBOL)) {
948 return (basic_mode (SUB (m)));
949 } else {
950 return (A68_FALSE);
951 }
952 } else if (IS (m, STRUCT_SYMBOL)) {
953 PACK_T *p = PACK (m);
954 for (; p != NO_PACK; FORWARD (p)) {
955 if (!primitive_mode (MOID (p))) {
956 return (A68_FALSE);
957 }
958 }
959 return (A68_TRUE);
960 } else {
961 return (A68_FALSE);
962 }
963 }
964
965 /**
966 @brief Whether basic mode, which is not a row.
967 @param m Mode to check.
968 @return See brief description.
969 **/
970
971 static BOOL_T
basic_mode_non_row(MOID_T * m)972 basic_mode_non_row (MOID_T * m)
973 {
974 if (denotation_mode (m)) {
975 return (A68_TRUE);
976 } else if (IS (m, REF_SYMBOL)) {
977 if (IS (SUB (m), REF_SYMBOL) || IS (SUB (m), PROC_SYMBOL)) {
978 return (A68_FALSE);
979 } else {
980 return (basic_mode_non_row (SUB (m)));
981 }
982 } else if (IS (m, STRUCT_SYMBOL)) {
983 PACK_T *p = PACK (m);
984 for (; p != NO_PACK; FORWARD (p)) {
985 if (!primitive_mode (MOID (p))) {
986 return (A68_FALSE);
987 }
988 }
989 return (A68_TRUE);
990 } else {
991 return (A68_FALSE);
992 }
993 }
994
995 /**
996 @brief Whether stems from certain attribute.
997 @param p Node in syntax tree.
998 @param att Attribute to comply to.
999 @return See brief description.
1000 **/
1001
1002 static NODE_T *
locate(NODE_T * p,int att)1003 locate (NODE_T * p, int att)
1004 {
1005 if (IS (p, VOIDING)) {
1006 return (locate (SUB (p), att));
1007 } else if (IS (p, UNIT)) {
1008 return (locate (SUB (p), att));
1009 } else if (IS (p, TERTIARY)) {
1010 return (locate (SUB (p), att));
1011 } else if (IS (p, SECONDARY)) {
1012 return (locate (SUB (p), att));
1013 } else if (IS (p, PRIMARY)) {
1014 return (locate (SUB (p), att));
1015 } else if (IS (p, att)) {
1016 return (p);
1017 } else {
1018 return (NO_NODE);
1019 }
1020 }
1021
1022 /**********************************************************/
1023 /* Basic unit check */
1024 /* Whether a unit is sufficiently "basic" to be compiled. */
1025 /**********************************************************/
1026
1027 /**
1028 @brief Whether basic collateral clause.
1029 @param p Node in syntax tree.
1030 @return See brief description.
1031 **/
1032
1033 static BOOL_T
basic_collateral(NODE_T * p)1034 basic_collateral (NODE_T * p)
1035 {
1036 if (p == NO_NODE) {
1037 return (A68_TRUE);
1038 } else if (IS (p, UNIT)) {
1039 return ((BOOL_T) (basic_mode (MOID (p)) && basic_unit (SUB (p)) && basic_collateral (NEXT (p))));
1040 } else {
1041 return ((BOOL_T) (basic_collateral (SUB (p)) && basic_collateral (NEXT (p))));
1042 }
1043 }
1044
1045 /**
1046 @brief Whether basic serial clause.
1047 @param p Node in syntax tree.
1048 @param total Total units.
1049 @param good Basic units.
1050 @return See brief description.
1051 **/
1052
1053 static void
count_basic_units(NODE_T * p,int * total,int * good)1054 count_basic_units (NODE_T * p, int *total, int *good)
1055 {
1056 for (; p != NO_NODE; FORWARD (p)) {
1057 if (IS (p, UNIT)) {
1058 (*total)++;
1059 if (basic_unit (p)) {
1060 (*good)++;
1061 }
1062 } else if (IS (p, DECLARATION_LIST)) {
1063 (*total)++;
1064 } else {
1065 count_basic_units (SUB (p), total, good);
1066 }
1067 }
1068 }
1069
1070 /**
1071 @brief Whether basic serial clause.
1072 @param p Node in syntax tree.
1073 @param want > 0 is how many units we allow, <= 0 is don't care
1074 @return See brief description.
1075 **/
1076
1077 static BOOL_T
basic_serial(NODE_T * p,int want)1078 basic_serial (NODE_T * p, int want)
1079 {
1080 int total = 0, good = 0;
1081 count_basic_units (p, &total, &good);
1082 if (want > 0) {
1083 return (total == want && total == good);
1084 } else {
1085 return (total == good);
1086 }
1087 }
1088
1089 /**
1090 @brief Whether basic indexer.
1091 @param p Node in syntax tree.
1092 @return See brief description.
1093 **/
1094
1095 static BOOL_T
basic_indexer(NODE_T * p)1096 basic_indexer (NODE_T * p)
1097 {
1098 if (p == NO_NODE) {
1099 return (A68_TRUE);
1100 } else if (IS (p, TRIMMER)) {
1101 return (A68_FALSE);
1102 } else if (IS (p, UNIT)) {
1103 return (basic_unit (p));
1104 } else {
1105 return ((BOOL_T) (basic_indexer (SUB (p)) && basic_indexer (NEXT (p))));
1106 }
1107 }
1108
1109 /**
1110 @brief Whether basic slice.
1111 @param p Starting node.
1112 @return See brief description.
1113 **/
1114
1115 static BOOL_T
basic_slice(NODE_T * p)1116 basic_slice (NODE_T * p)
1117 {
1118 if (IS (p, SLICE)) {
1119 NODE_T *prim = SUB (p);
1120 NODE_T *idf = locate (prim, IDENTIFIER);
1121 if (idf != NO_NODE) {
1122 NODE_T *indx = NEXT (prim);
1123 return (basic_indexer (indx));
1124 }
1125 }
1126 return (A68_FALSE);
1127 }
1128
1129 /**
1130 @brief Whether basic argument.
1131 @param p Starting node.
1132 @return See brief description.
1133 **/
1134
1135 static BOOL_T
basic_argument(NODE_T * p)1136 basic_argument (NODE_T * p)
1137 {
1138 if (p == NO_NODE) {
1139 return (A68_TRUE);
1140 } else if (IS (p, UNIT)) {
1141 return ((BOOL_T) (basic_mode (MOID (p)) && basic_unit (p) && basic_argument (NEXT (p))));
1142 } else {
1143 return ((BOOL_T) (basic_argument (SUB (p)) && basic_argument (NEXT (p))));
1144 }
1145 }
1146
1147 /**
1148 @brief Whether basic call.
1149 @param p Starting node.
1150 @return See brief description.
1151 **/
1152
1153 static BOOL_T
basic_call(NODE_T * p)1154 basic_call (NODE_T * p)
1155 {
1156 if (IS (p, CALL)) {
1157 NODE_T *prim = SUB (p);
1158 NODE_T *idf = locate (prim, IDENTIFIER);
1159 if (idf == NO_NODE) {
1160 return (A68_FALSE);
1161 } else if (SUB_MOID (idf) == MOID (p)) { /* Prevent partial parametrisation */
1162 int k;
1163 for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
1164 if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
1165 NODE_T *args = NEXT (prim);
1166 return (basic_argument (args));
1167 }
1168 }
1169 }
1170 }
1171 return (A68_FALSE);
1172 }
1173
1174 /**
1175 @brief Whether basic monadic formula.
1176 @param p Starting node.
1177 @return See brief description.
1178 **/
1179
1180 static BOOL_T
basic_monadic_formula(NODE_T * p)1181 basic_monadic_formula (NODE_T * p)
1182 {
1183 if (IS (p, MONADIC_FORMULA)) {
1184 NODE_T *op = SUB (p);
1185 int k;
1186 for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
1187 if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
1188 NODE_T *rhs = NEXT (op);
1189 return (basic_unit (rhs));
1190 }
1191 }
1192 }
1193 return (A68_FALSE);
1194 }
1195
1196 /**
1197 @brief Whether basic dyadic formula.
1198 @param p Starting node.
1199 @return See brief description.
1200 **/
1201
1202 static BOOL_T
basic_formula(NODE_T * p)1203 basic_formula (NODE_T * p)
1204 {
1205 if (IS (p, FORMULA)) {
1206 NODE_T *lhs = SUB (p);
1207 NODE_T *op = NEXT (lhs);
1208 if (op == NO_NODE) {
1209 return (basic_monadic_formula (lhs));
1210 } else {
1211 int k;
1212 for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
1213 if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
1214 NODE_T *rhs = NEXT (op);
1215 return ((BOOL_T) (basic_unit (lhs) && basic_unit (rhs)));
1216 }
1217 }
1218 }
1219 }
1220 return (A68_FALSE);
1221 }
1222
1223 /**
1224 @brief Whether basic conditional clause.
1225 @param p Starting node.
1226 @return See brief description.
1227 **/
1228
1229 static BOOL_T
basic_conditional(NODE_T * p)1230 basic_conditional (NODE_T * p)
1231 {
1232 if (!(IS (p, IF_PART) || IS (p, OPEN_PART))) {
1233 return (A68_FALSE);
1234 }
1235 if (!basic_serial (NEXT_SUB (p), 1)) {
1236 return (A68_FALSE);
1237 }
1238 FORWARD (p);
1239 if (!(IS (p, THEN_PART) || IS (p, CHOICE))) {
1240 return (A68_FALSE);
1241 }
1242 if (!basic_serial (NEXT_SUB (p), 1)) {
1243 return (A68_FALSE);
1244 }
1245 FORWARD (p);
1246 if (IS (p, ELSE_PART) || IS (p, CHOICE)) {
1247 return (basic_serial (NEXT_SUB (p), 1));
1248 } else if (IS (p, FI_SYMBOL)) {
1249 return (A68_TRUE);
1250 } else {
1251 return (A68_FALSE);
1252 }
1253 }
1254
1255 /**
1256 @brief Whether basic unit.
1257 @param p Starting node.
1258 @return See brief description.
1259 **/
1260
1261 static BOOL_T
basic_unit(NODE_T * p)1262 basic_unit (NODE_T * p)
1263 {
1264 if (p == NO_NODE) {
1265 return (A68_FALSE);
1266 } else if (IS (p, UNIT)) {
1267 return (basic_unit (SUB (p)));
1268 } else if (IS (p, TERTIARY)) {
1269 return (basic_unit (SUB (p)));
1270 } else if (IS (p, SECONDARY)) {
1271 return (basic_unit (SUB (p)));
1272 } else if (IS (p, PRIMARY)) {
1273 return (basic_unit (SUB (p)));
1274 } else if (IS (p, ENCLOSED_CLAUSE)) {
1275 return (basic_unit (SUB (p)));
1276 } else if (IS (p, CLOSED_CLAUSE)) {
1277 return (basic_serial (NEXT_SUB (p), 1));
1278 } else if (IS (p, COLLATERAL_CLAUSE)) {
1279 return (basic_mode (MOID (p)) && basic_collateral (NEXT_SUB (p)));
1280 } else if (IS (p, CONDITIONAL_CLAUSE)) {
1281 return (basic_mode (MOID (p)) && basic_conditional (SUB (p)));
1282 } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), IDENTIFIER) != NO_NODE) {
1283 NODE_T *dst = SUB_SUB (p);
1284 NODE_T *src = NEXT_NEXT (dst);
1285 return ((BOOL_T) basic_unit (src) && basic_mode_non_row (MOID (src)));
1286 } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SLICE) != NO_NODE) {
1287 NODE_T *dst = SUB_SUB (p);
1288 NODE_T *src = NEXT_NEXT (dst);
1289 NODE_T *slice = locate (dst, SLICE);
1290 return ((BOOL_T) (IS (MOID (slice), REF_SYMBOL) && basic_slice (slice) && basic_unit (src) && basic_mode_non_row (MOID (src))));
1291 } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SELECTION) != NO_NODE) {
1292 NODE_T *dst = SUB_SUB (p);
1293 NODE_T *src = NEXT_NEXT (dst);
1294 return ((BOOL_T) (locate (NEXT_SUB (locate (dst, SELECTION)), IDENTIFIER) != NO_NODE && basic_unit (src) && basic_mode_non_row (MOID (dst))));
1295 } else if (IS (p, VOIDING)) {
1296 return (basic_unit (SUB (p)));
1297 } else if (IS (p, DEREFERENCING) && locate (SUB (p), IDENTIFIER)) {
1298 return ((BOOL_T) (basic_mode (MOID (p)) && BASIC (SUB (p), IDENTIFIER)));
1299 } else if (IS (p, DEREFERENCING) && locate (SUB (p), SLICE)) {
1300 NODE_T *slice = locate (SUB (p), SLICE);
1301 return ((BOOL_T) (basic_mode (MOID (p)) && IS (MOID (SUB (slice)), REF_SYMBOL) && basic_slice (slice)));
1302 } else if (IS (p, DEREFERENCING) && locate (SUB (p), SELECTION)) {
1303 return ((BOOL_T) (primitive_mode (MOID (p)) && BASIC (SUB (p), SELECTION)));
1304 } else if (IS (p, WIDENING)) {
1305 if (WIDEN_TO (p, INT, REAL)) {
1306 return (basic_unit (SUB (p)));
1307 } else if (WIDEN_TO (p, INT, LONG_INT)) {
1308 return (basic_unit (SUB (p)));
1309 } else if (WIDEN_TO (p, REAL, COMPLEX)) {
1310 return (basic_unit (SUB (p)));
1311 } else if (WIDEN_TO (p, REAL, LONG_REAL)) {
1312 return (basic_unit (SUB (p)));
1313 } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) {
1314 return (basic_unit (SUB (p)));
1315 } else {
1316 return (A68_FALSE);
1317 }
1318 } else if (IS (p, IDENTIFIER)) {
1319 if (A68G_STANDENV_PROC (TAX (p))) {
1320 int k;
1321 for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
1322 if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
1323 return (A68_TRUE);
1324 }
1325 }
1326 return (A68_FALSE);
1327 } else {
1328 return (basic_mode (MOID (p)));
1329 }
1330 } else if (IS (p, DENOTATION)) {
1331 return (denotation_mode (MOID (p)));
1332 } else if (IS (p, MONADIC_FORMULA)) {
1333 return ((BOOL_T) (basic_mode (MOID (p)) && basic_monadic_formula (p)));
1334 } else if (IS (p, FORMULA)) {
1335 return ((BOOL_T) (basic_mode (MOID (p)) && basic_formula (p)));
1336 } else if (IS (p, CALL)) {
1337 return ((BOOL_T) (basic_mode (MOID (p)) && basic_call (p)));
1338 } else if (IS (p, CAST)) {
1339 return ((BOOL_T) (folder_mode (MOID (SUB (p))) && basic_unit (NEXT_SUB (p))));
1340 } else if (IS (p, SLICE)) {
1341 return ((BOOL_T) (basic_mode (MOID (p)) && basic_slice (p)));
1342 } else if (IS (p, SELECTION)) {
1343 NODE_T *sec = locate (NEXT_SUB (p), IDENTIFIER);
1344 if (sec == NO_NODE) {
1345 return (A68_FALSE);
1346 } else {
1347 return (basic_mode_non_row (MOID (sec)));
1348 }
1349 } else if (IS (p, IDENTITY_RELATION)) {
1350 #define GOOD(p) (locate (p, IDENTIFIER) != NO_NODE && IS (MOID (locate ((p), IDENTIFIER)), REF_SYMBOL))
1351 NODE_T *lhs = SUB (p);
1352 NODE_T *rhs = NEXT_NEXT (lhs);
1353 if (GOOD (lhs) && GOOD (rhs)) {
1354 return (A68_TRUE);
1355 } else if (GOOD (lhs) && locate (rhs, NIHIL) != NO_NODE) {
1356 return (A68_TRUE);
1357 } else {
1358 return (A68_FALSE);
1359 }
1360 #undef GOOD
1361 } else {
1362 return (A68_FALSE);
1363 }
1364 }
1365
1366 /*******************************************************************/
1367 /* Constant folder */
1368 /* Uses interpreter routines to calculate compile-time expressions */
1369 /*******************************************************************/
1370
1371 /***********************/
1372 /* Constant unit check */
1373 /***********************/
1374
1375 /**
1376 @brief Whether constant collateral clause.
1377 @param p Node in syntax tree.
1378 @return See brief description.
1379 **/
1380
1381 static BOOL_T
constant_collateral(NODE_T * p)1382 constant_collateral (NODE_T * p)
1383 {
1384 if (p == NO_NODE) {
1385 return (A68_TRUE);
1386 } else if (IS (p, UNIT)) {
1387 return ((BOOL_T) (folder_mode (MOID (p)) && constant_unit (SUB (p)) && constant_collateral (NEXT (p))));
1388 } else {
1389 return ((BOOL_T) (constant_collateral (SUB (p)) && constant_collateral (NEXT (p))));
1390 }
1391 }
1392
1393 /**
1394 @brief Whether constant serial clause.
1395 @param p Node in syntax tree.
1396 @param total Total units.
1397 @param good Basic units.
1398 @return See brief description.
1399 **/
1400
1401 static void
count_constant_units(NODE_T * p,int * total,int * good)1402 count_constant_units (NODE_T * p, int *total, int *good)
1403 {
1404 if (p != NO_NODE) {
1405 if (IS (p, UNIT)) {
1406 (*total)++;
1407 if (constant_unit (p)) {
1408 (*good)++;
1409 }
1410 count_constant_units (NEXT (p), total, good);
1411 } else {
1412 count_constant_units (SUB (p), total, good);
1413 count_constant_units (NEXT (p), total, good);
1414 }
1415 }
1416 }
1417
1418 /**
1419 @brief Whether constant serial clause.
1420 @param p Node in syntax tree.
1421 @param want > 0 is how many units we allow, <= 0 is don't care
1422 @return See brief description.
1423 **/
1424
1425 static BOOL_T
constant_serial(NODE_T * p,int want)1426 constant_serial (NODE_T * p, int want)
1427 {
1428 int total = 0, good = 0;
1429 count_constant_units (p, &total, &good);
1430 if (want > 0) {
1431 return (total == want && total == good);
1432 } else {
1433 return (total == good);
1434 }
1435 }
1436
1437 /**
1438 @brief Whether constant argument.
1439 @param p Starting node.
1440 @return See brief description.
1441 **/
1442
1443 static BOOL_T
constant_argument(NODE_T * p)1444 constant_argument (NODE_T * p)
1445 {
1446 if (p == NO_NODE) {
1447 return (A68_TRUE);
1448 } else if (IS (p, UNIT)) {
1449 return ((BOOL_T) (folder_mode (MOID (p)) && constant_unit (p) && constant_argument (NEXT (p))));
1450 } else {
1451 return ((BOOL_T) (constant_argument (SUB (p)) && constant_argument (NEXT (p))));
1452 }
1453 }
1454
1455 /**
1456 @brief Whether constant call.
1457 @param p Starting node.
1458 @return See brief description.
1459 **/
1460
1461 static BOOL_T
constant_call(NODE_T * p)1462 constant_call (NODE_T * p)
1463 {
1464 if (IS (p, CALL)) {
1465 NODE_T *prim = SUB (p);
1466 NODE_T *idf = locate (prim, IDENTIFIER);
1467 if (idf != NO_NODE) {
1468 int k;
1469 for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
1470 if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
1471 NODE_T *args = NEXT (prim);
1472 return (constant_argument (args));
1473 }
1474 }
1475 }
1476 }
1477 return (A68_FALSE);
1478 }
1479
1480 /**
1481 @brief Whether constant monadic formula.
1482 @param p Starting node.
1483 @return See brief description.
1484 **/
1485
1486 static BOOL_T
constant_monadic_formula(NODE_T * p)1487 constant_monadic_formula (NODE_T * p)
1488 {
1489 if (IS (p, MONADIC_FORMULA)) {
1490 NODE_T *op = SUB (p);
1491 int k;
1492 for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
1493 if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
1494 NODE_T *rhs = NEXT (op);
1495 return (constant_unit (rhs));
1496 }
1497 }
1498 }
1499 return (A68_FALSE);
1500 }
1501
1502 /**
1503 @brief Whether constant dyadic formula.
1504 @param p Starting node.
1505 @return See brief description.
1506 **/
1507
1508 static BOOL_T
constant_formula(NODE_T * p)1509 constant_formula (NODE_T * p)
1510 {
1511 if (IS (p, FORMULA)) {
1512 NODE_T *lhs = SUB (p);
1513 NODE_T *op = NEXT (lhs);
1514 if (op == NO_NODE) {
1515 return (constant_monadic_formula (lhs));
1516 } else {
1517 int k;
1518 for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
1519 if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
1520 NODE_T *rhs = NEXT (op);
1521 return ((BOOL_T) (constant_unit (lhs) && constant_unit (rhs)));
1522 }
1523 }
1524 }
1525 }
1526 return (A68_FALSE);
1527 }
1528
1529 /**
1530 @brief Whether constant unit.
1531 @param p Starting node.
1532 @return See brief description.
1533 **/
1534
1535 BOOL_T
constant_unit(NODE_T * p)1536 constant_unit (NODE_T * p)
1537 {
1538 if (p == NO_NODE) {
1539 return (A68_FALSE);
1540 } else if (IS (p, UNIT)) {
1541 return (constant_unit (SUB (p)));
1542 } else if (IS (p, TERTIARY)) {
1543 return (constant_unit (SUB (p)));
1544 } else if (IS (p, SECONDARY)) {
1545 return (constant_unit (SUB (p)));
1546 } else if (IS (p, PRIMARY)) {
1547 return (constant_unit (SUB (p)));
1548 } else if (IS (p, ENCLOSED_CLAUSE)) {
1549 return (constant_unit (SUB (p)));
1550 } else if (IS (p, CLOSED_CLAUSE)) {
1551 return (constant_serial (NEXT_SUB (p), 1));
1552 } else if (IS (p, COLLATERAL_CLAUSE)) {
1553 return (folder_mode (MOID (p)) && constant_collateral (NEXT_SUB (p)));
1554 } else if (IS (p, WIDENING)) {
1555 if (WIDEN_TO (p, INT, REAL)) {
1556 return (constant_unit (SUB (p)));
1557 } else if (WIDEN_TO (p, INT, LONG_INT)) {
1558 return (constant_unit (SUB (p)));
1559 } else if (WIDEN_TO (p, REAL, COMPLEX)) {
1560 return (constant_unit (SUB (p)));
1561 } else if (WIDEN_TO (p, REAL, LONG_REAL)) {
1562 return (constant_unit (SUB (p)));
1563 } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) {
1564 return (constant_unit (SUB (p)));
1565 } else {
1566 return (A68_FALSE);
1567 }
1568 } else if (IS (p, IDENTIFIER)) {
1569 if (A68G_STANDENV_PROC (TAX (p))) {
1570 int k;
1571 for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
1572 if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
1573 return (A68_TRUE);
1574 }
1575 }
1576 return (A68_FALSE);
1577 } else {
1578 /* Possible constant folding */
1579 NODE_T *def = NODE (TAX (p));
1580 BOOL_T ret = A68_FALSE;
1581 if (STATUS (p) & COOKIE_MASK) {
1582 diagnostic_node (A68_WARNING, p, WARNING_UNINITIALISED);
1583 } else {
1584 STATUS (p) |= COOKIE_MASK;
1585 if (folder_mode (MOID (p)) && def != NO_NODE && NEXT (def) != NO_NODE && IS (NEXT (def), EQUALS_SYMBOL)) {
1586 ret = constant_unit (NEXT_NEXT (def));
1587 }
1588 }
1589 STATUS (p) &= !(COOKIE_MASK);
1590 return (ret);
1591 }
1592 } else if (IS (p, DENOTATION)) {
1593 return (denotation_mode (MOID (p)));
1594 } else if (IS (p, MONADIC_FORMULA)) {
1595 return ((BOOL_T) (folder_mode (MOID (p)) && constant_monadic_formula (p)));
1596 } else if (IS (p, FORMULA)) {
1597 return ((BOOL_T) (folder_mode (MOID (p)) && constant_formula (p)));
1598 } else if (IS (p, CALL)) {
1599 return ((BOOL_T) (folder_mode (MOID (p)) && constant_call (p)));
1600 } else if (IS (p, CAST)) {
1601 return ((BOOL_T) (folder_mode (MOID (SUB (p))) && constant_unit (NEXT_SUB (p))));
1602 } else {
1603 return (A68_FALSE);
1604 }
1605 }
1606
1607 /*****************************************************************/
1608 /* Evaluate compile-time expressions using interpreter routines. */
1609 /*****************************************************************/
1610
1611 /**
1612 @brief Push denotation.
1613 @param p Node in syntax tree.
1614 **/
1615
1616 static void
push_denotation(NODE_T * p)1617 push_denotation (NODE_T * p)
1618 {
1619 #define PUSH_DENOTATION(mode, decl) {\
1620 decl z;\
1621 NODE_T *s = (IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p));\
1622 if (genie_string_to_value_internal (p, MODE (mode), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {\
1623 diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (mode));\
1624 }\
1625 PUSH_PRIMITIVE (p, VALUE (&z), decl);}
1626 /**/
1627 #define PUSH_LONG_DENOTATION(mode, decl) {\
1628 decl z;\
1629 NODE_T *s = (IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p));\
1630 if (genie_string_to_value_internal (p, MODE (mode), NSYMBOL (s), (BYTE_T *) z) == A68_FALSE) {\
1631 diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (mode));\
1632 }\
1633 PUSH (p, &z, SIZE (MODE (mode)));}
1634 /**/ if (MOID (p) == MODE (INT)) {
1635 PUSH_DENOTATION (INT, A68_INT);
1636 } else if (MOID (p) == MODE (REAL)) {
1637 PUSH_DENOTATION (REAL, A68_REAL);
1638 } else if (MOID (p) == MODE (BOOL)) {
1639 PUSH_DENOTATION (BOOL, A68_BOOL);
1640 } else if (MOID (p) == MODE (CHAR)) {
1641 if ((NSYMBOL (p))[0] == NULL_CHAR) {
1642 PUSH_PRIMITIVE (p, NULL_CHAR, A68_CHAR);
1643 } else {
1644 PUSH_PRIMITIVE (p, (NSYMBOL (p))[0], A68_CHAR);
1645 }
1646 } else if (MOID (p) == MODE (BITS)) {
1647 PUSH_DENOTATION (BITS, A68_BITS);
1648 } else if (MOID (p) == MODE (LONG_INT)) {
1649 PUSH_LONG_DENOTATION (LONG_INT, A68_LONG);
1650 } else if (MOID (p) == MODE (LONG_REAL)) {
1651 PUSH_LONG_DENOTATION (LONG_REAL, A68_LONG);
1652 }
1653 #undef PUSH_DENOTATION
1654 #undef PUSH_LONG_DENOTATION
1655 }
1656
1657 /**
1658 @brief Push widening.
1659 @param p Starting node.
1660 **/
1661
1662 static void
push_widening(NODE_T * p)1663 push_widening (NODE_T * p)
1664 {
1665 push_unit (SUB (p));
1666 if (WIDEN_TO (p, INT, REAL)) {
1667 A68_INT k;
1668 POP_OBJECT (p, &k, A68_INT);
1669 PUSH_PRIMITIVE (p, (double) VALUE (&k), A68_REAL);
1670 } else if (WIDEN_TO (p, REAL, COMPLEX)) {
1671 PUSH_PRIMITIVE (p, 0.0, A68_REAL);
1672 } else if (WIDEN_TO (p, INT, LONG_INT)) {
1673 genie_lengthen_int_to_long_mp (p);
1674 } else if (WIDEN_TO (p, REAL, LONG_REAL)) {
1675 genie_lengthen_real_to_long_mp (p);
1676 } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) {
1677 /* 1:1 mapping */ ;
1678 }
1679 }
1680
1681 /**
1682 @brief Code collateral units.
1683 @param p Starting node.
1684 **/
1685
1686 static void
push_collateral_units(NODE_T * p)1687 push_collateral_units (NODE_T * p)
1688 {
1689 if (p == NO_NODE) {
1690 return;
1691 } else if (IS (p, UNIT)) {
1692 push_unit (p);
1693 } else {
1694 push_collateral_units (SUB (p));
1695 push_collateral_units (NEXT (p));
1696 }
1697 }
1698
1699 /**
1700 @brief Code argument.
1701 @param p Starting node.
1702 **/
1703
1704 static void
push_argument(NODE_T * p)1705 push_argument (NODE_T * p)
1706 {
1707 for (; p != NO_NODE; FORWARD (p)) {
1708 if (IS (p, UNIT)) {
1709 push_unit (p);
1710 } else {
1711 push_argument (SUB (p));
1712 }
1713 }
1714 }
1715
1716 /**
1717 @brief Push unit.
1718 @param p Starting node.
1719 **/
1720
1721 void
push_unit(NODE_T * p)1722 push_unit (NODE_T * p)
1723 {
1724 if (p == NO_NODE) {
1725 return;
1726 }
1727 if (IS (p, UNIT)) {
1728 push_unit (SUB (p));
1729 } else if (IS (p, TERTIARY)) {
1730 push_unit (SUB (p));
1731 } else if (IS (p, SECONDARY)) {
1732 push_unit (SUB (p));
1733 } else if (IS (p, PRIMARY)) {
1734 push_unit (SUB (p));
1735 } else if (IS (p, ENCLOSED_CLAUSE)) {
1736 push_unit (SUB (p));
1737 } else if (IS (p, CLOSED_CLAUSE)) {
1738 push_unit (SUB (NEXT_SUB (p)));
1739 } else if (IS (p, COLLATERAL_CLAUSE)) {
1740 push_collateral_units (NEXT_SUB (p));
1741 } else if (IS (p, WIDENING)) {
1742 push_widening (p);
1743 } else if (IS (p, IDENTIFIER)) {
1744 if (A68G_STANDENV_PROC (TAX (p))) {
1745 (void) (*(PROCEDURE (TAX (p)))) (p);
1746 } else {
1747 /* Possible constant folding */
1748 NODE_T *def = NODE (TAX (p));
1749 push_unit (NEXT_NEXT (def));
1750 }
1751 } else if (IS (p, DENOTATION)) {
1752 push_denotation (p);
1753 } else if (IS (p, MONADIC_FORMULA)) {
1754 NODE_T *op = SUB (p);
1755 NODE_T *rhs = NEXT (op);
1756 push_unit (rhs);
1757 (*(PROCEDURE (TAX (op)))) (op);
1758 } else if (IS (p, FORMULA)) {
1759 NODE_T *lhs = SUB (p);
1760 NODE_T *op = NEXT (lhs);
1761 if (op == NO_NODE) {
1762 push_unit (lhs);
1763 } else {
1764 NODE_T *rhs = NEXT (op);
1765 push_unit (lhs);
1766 push_unit (rhs);
1767 (*(PROCEDURE (TAX (op)))) (op);
1768 }
1769 } else if (IS (p, CALL)) {
1770 NODE_T *prim = SUB (p);
1771 NODE_T *args = NEXT (prim);
1772 NODE_T *idf = locate (prim, IDENTIFIER);
1773 push_argument (args);
1774 (void) (*(PROCEDURE (TAX (idf)))) (p);
1775 } else if (IS (p, CAST)) {
1776 push_unit (NEXT_SUB (p));
1777 }
1778 }
1779
1780 /**
1781 @brief Code constant folding.
1782 @param p Node to start.
1783 @param out Output file descriptor.
1784 @param phase Phase of code generation.
1785 **/
1786
1787 static void
constant_folder(NODE_T * p,FILE_T out,int phase)1788 constant_folder (NODE_T * p, FILE_T out, int phase)
1789 {
1790 if (phase == L_DECLARE) {
1791 if (MOID (p) == MODE (COMPLEX)) {
1792 char acc[NAME_SIZE];
1793 A68_REAL re, im;
1794 (void) make_name (acc, CON, "", NUMBER (p));
1795 stack_pointer = 0;
1796 push_unit (p);
1797 POP_OBJECT (p, &im, A68_REAL);
1798 POP_OBJECT (p, &re, A68_REAL);
1799 indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_COMPLEX %s = {", acc));
1800 undentf (out, snprintf (line, SNPRINTF_SIZE, "{INIT_MASK, %.*g}", REAL_WIDTH, VALUE (&re)));
1801 undentf (out, snprintf (line, SNPRINTF_SIZE, ", {INIT_MASK, %.*g}", REAL_WIDTH, VALUE (&im)));
1802 undent (out, "};\n");
1803 ABEND (stack_pointer > 0, "stack not empty", NO_TEXT);
1804 } else if (LONG_MODE (MOID (p))) {
1805 char acc[NAME_SIZE];
1806 A68_LONG z;
1807 int k;
1808 (void) make_name (acc, CON, "", NUMBER (p));
1809 stack_pointer = 0;
1810 push_unit (p);
1811 POP (p, &z, SIZE (MOID (p)));
1812 indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_LONG %s = {INIT_MASK, %.0f", acc, z[1]));
1813 for (k = 1; k <= LONG_MP_DIGITS; k++) {
1814 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %.0f", z[k + 1]));
1815 }
1816 undent (out, "};\n");
1817 ABEND (stack_pointer > 0, "stack not empty", NO_TEXT);
1818 }
1819 } else if (phase == L_EXECUTE) {
1820 if (MOID (p) == MODE (COMPLEX)) {
1821 /* Done at declaration stage */
1822 } else if (LONG_MODE (MOID (p))) {
1823 /* Done at declaration stage */
1824 }
1825 } else if (phase == L_YIELD) {
1826 if (MOID (p) == MODE (INT)) {
1827 A68_INT k;
1828 stack_pointer = 0;
1829 push_unit (p);
1830 POP_OBJECT (p, &k, A68_INT);
1831 ASSERT (snprintf (line, SNPRINTF_SIZE, "%d", VALUE (&k)) >= 0);
1832 undent (out, line);
1833 ABEND (stack_pointer > 0, "stack not empty", NO_TEXT);
1834 } else if (MOID (p) == MODE (REAL)) {
1835 A68_REAL x;
1836 double conv;
1837 stack_pointer = 0;
1838 push_unit (p);
1839 POP_OBJECT (p, &x, A68_REAL);
1840 /* Mind overflowing or underflowing values */
1841 if (VALUE (&x) == DBL_MAX) {
1842 undent (out, "DBL_MAX");
1843 } else if (VALUE (&x) == -DBL_MAX) {
1844 undent (out, "(-DBL_MAX)");
1845 } else {
1846 ASSERT (snprintf (line, SNPRINTF_SIZE, "%.*g", REAL_WIDTH, VALUE (&x)) >= 0);
1847 errno = 0;
1848 conv = strtod (line, NO_VAR);
1849 if (errno == ERANGE && conv == 0.0) {
1850 undent (out, "0.0");
1851 } else if (errno == ERANGE && conv == HUGE_VAL) {
1852 diagnostic_node (A68_WARNING, p, WARNING_OVERFLOW, MODE (REAL));
1853 undent (out, "DBL_MAX");
1854 } else if (errno == ERANGE && conv == -HUGE_VAL) {
1855 diagnostic_node (A68_WARNING, p, WARNING_OVERFLOW, MODE (REAL));
1856 undent (out, "(-DBL_MAX)");
1857 } else if (errno == ERANGE && conv >= 0) {
1858 diagnostic_node (A68_WARNING, p, WARNING_UNDERFLOW, MODE (REAL));
1859 undent (out, "DBL_MIN");
1860 } else if (errno == ERANGE && conv < 0) {
1861 diagnostic_node (A68_WARNING, p, WARNING_UNDERFLOW, MODE (REAL));
1862 undent (out, "(-DBL_MIN)");
1863 } else {
1864 if (strchr (line, '.') == NO_TEXT && strchr (line, 'e') == NO_TEXT && strchr (line, 'E') == NO_TEXT) {
1865 strncat (line, ".0", BUFFER_SIZE);
1866 }
1867 undent (out, line);
1868 }
1869 }
1870 ABEND (stack_pointer > 0, "stack not empty", NO_TEXT);
1871 } else if (MOID (p) == MODE (BOOL)) {
1872 A68_BOOL b;
1873 stack_pointer = 0;
1874 push_unit (p);
1875 POP_OBJECT (p, &b, A68_BOOL);
1876 ASSERT (snprintf (line, SNPRINTF_SIZE, "%s", (VALUE (&b) ? "A68_TRUE" : "A68_FALSE")) >= 0);
1877 undent (out, line);
1878 ABEND (stack_pointer > 0, "stack not empty", NO_TEXT);
1879 } else if (MOID (p) == MODE (CHAR)) {
1880 A68_CHAR c;
1881 stack_pointer = 0;
1882 push_unit (p);
1883 POP_OBJECT (p, &c, A68_CHAR);
1884 if (VALUE (&c) == '\'') {
1885 undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\\''"));
1886 } else if (VALUE (&c) == '\\') {
1887 undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\\\'"));
1888 } else if (VALUE (&c) == NULL_CHAR) {
1889 undentf (out, snprintf (line, SNPRINTF_SIZE, "NULL_CHAR"));
1890 } else if (IS_PRINT (VALUE (&c))) {
1891 undentf (out, snprintf (line, SNPRINTF_SIZE, "'%c'", VALUE (&c)));
1892 } else {
1893 undentf (out, snprintf (line, SNPRINTF_SIZE, "(int) 0x%04x", (unsigned) VALUE (&c)));
1894 }
1895 ABEND (stack_pointer > 0, "stack not empty", NO_TEXT);
1896 } else if (MOID (p) == MODE (BITS)) {
1897 A68_BITS b;
1898 stack_pointer = 0;
1899 push_unit (p);
1900 POP_OBJECT (p, &b, A68_BITS);
1901 ASSERT (snprintf (line, SNPRINTF_SIZE, "0x%x", VALUE (&b)) >= 0);
1902 undent (out, line);
1903 ABEND (stack_pointer > 0, "stack not empty", NO_TEXT);
1904 } else if (MOID (p) == MODE (COMPLEX)) {
1905 char acc[NAME_SIZE];
1906 (void) make_name (acc, CON, "", NUMBER (p));
1907 undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) %s", acc));
1908 } else if (LONG_MODE (MOID (p))) {
1909 char acc[NAME_SIZE];
1910 (void) make_name (acc, CON, "", NUMBER (p));
1911 undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) %s", acc));
1912 }
1913 }
1914 }
1915
1916 /********************************************/
1917 /* Auxilliary routines for emitting C code. */
1918 /********************************************/
1919
1920 /**
1921 @brief Whether frame needs initialisation.
1922 @param p Node in syntax tree.
1923 **/
1924
1925 static BOOL_T
need_initialise_frame(NODE_T * p)1926 need_initialise_frame (NODE_T * p)
1927 {
1928 TAG_T *tag;
1929 int count;
1930 for (tag = ANONYMOUS (TABLE (p)); tag != NO_TAG; FORWARD (tag)) {
1931 if (PRIO (tag) == ROUTINE_TEXT) {
1932 return (A68_TRUE);
1933 } else if (PRIO (tag) == FORMAT_TEXT) {
1934 return (A68_TRUE);
1935 }
1936 }
1937 count = 0;
1938 genie_find_proc_op (p, &count);
1939 if (count > 0) {
1940 return (A68_TRUE);
1941 } else {
1942 return (A68_FALSE);
1943 }
1944 }
1945
1946 /**
1947 @brief Comment source line.
1948 @param p Node in syntax tree.
1949 @param out Output file descriptor.
1950 @param want_space Space required.
1951 @param max_print Maximum items to print.
1952 **/
1953
1954 static void
comment_tree(NODE_T * p,FILE_T out,int * want_space,int * max_print)1955 comment_tree (NODE_T * p, FILE_T out, int *want_space, int *max_print)
1956 {
1957 /* Take care not to generate nested comments */
1958 #define UNDENT(out, p) {\
1959 char * q;\
1960 for (q = p; q[0] != NULL_CHAR; q ++) {\
1961 if (q[0] == '*' && q[1] == '/') {\
1962 undent (out, "\\*\\/");\
1963 q ++;\
1964 } else if (q[0] == '/' && q[1] == '*') {\
1965 undent (out, "\\/\\*");\
1966 q ++;\
1967 } else {\
1968 char w[2];\
1969 w[0] = q[0];\
1970 w[1] = NULL_CHAR;\
1971 undent (out, w);\
1972 }\
1973 }}
1974 /**/ for (; p != NO_NODE && (*max_print) >= 0; FORWARD (p)) {
1975 if (IS (p, ROW_CHAR_DENOTATION)) {
1976 if (*want_space != 0) {
1977 UNDENT (out, " ");
1978 }
1979 UNDENT (out, "\"");
1980 UNDENT (out, NSYMBOL (p));
1981 UNDENT (out, "\"");
1982 *want_space = 2;
1983 } else if (SUB (p) != NO_NODE) {
1984 comment_tree (SUB (p), out, want_space, max_print);
1985 } else if (NSYMBOL (p)[0] == '(' || NSYMBOL (p)[0] == '[' || NSYMBOL (p)[0] == '{') {
1986 if (*want_space == 2) {
1987 UNDENT (out, " ");
1988 }
1989 UNDENT (out, NSYMBOL (p));
1990 *want_space = 0;
1991 } else if (NSYMBOL (p)[0] == ')' || NSYMBOL (p)[0] == ']' || NSYMBOL (p)[0] == '}') {
1992 UNDENT (out, NSYMBOL (p));
1993 *want_space = 1;
1994 } else if (NSYMBOL (p)[0] == ';' || NSYMBOL (p)[0] == ',') {
1995 UNDENT (out, NSYMBOL (p));
1996 *want_space = 2;
1997 } else if (strlen (NSYMBOL (p)) == 1 && (NSYMBOL (p)[0] == '.' || NSYMBOL (p)[0] == ':')) {
1998 UNDENT (out, NSYMBOL (p));
1999 *want_space = 2;
2000 } else {
2001 if (*want_space != 0) {
2002 UNDENT (out, " ");
2003 }
2004 if ((*max_print) > 0) {
2005 UNDENT (out, NSYMBOL (p));
2006 } else if ((*max_print) == 0) {
2007 if (*want_space == 0) {
2008 UNDENT (out, " ");
2009 }
2010 UNDENT (out, "...");
2011 }
2012 (*max_print)--;
2013 if (IS_UPPER (NSYMBOL (p)[0])) {
2014 *want_space = 2;
2015 } else if (!IS_ALNUM (NSYMBOL (p)[0])) {
2016 *want_space = 2;
2017 } else {
2018 *want_space = 1;
2019 }
2020 }
2021 }
2022 #undef UNDENT
2023 }
2024
2025 /**
2026 @brief Comment source line.
2027 @param p Node in syntax tree.
2028 @param out Output file descriptor.
2029 **/
2030
2031 static void
comment_source(NODE_T * p,FILE_T out)2032 comment_source (NODE_T * p, FILE_T out)
2033 {
2034 int want_space = 0, max_print = 16;
2035 undentf (out, snprintf (line, SNPRINTF_SIZE, "/* %s: %d: ", FILENAME (LINE (INFO (p))), LINE_NUMBER (p)));
2036 comment_tree (p, out, &want_space, &max_print);
2037 undent (out, " */\n");
2038 }
2039
2040 /**
2041 @brief Inline comment source line.
2042 @param p Node in syntax tree.
2043 @param out Output file descriptor.
2044 **/
2045
2046 static void
inline_comment_source(NODE_T * p,FILE_T out)2047 inline_comment_source (NODE_T * p, FILE_T out)
2048 {
2049 int want_space = 0, max_print = 8;
2050 undent (out, " /* ");
2051 comment_tree (p, out, &want_space, &max_print);
2052 undent (out, " */");
2053 }
2054
2055 /**
2056 @brief Write prelude.
2057 @param out Output file descriptor.
2058 **/
2059
2060 static void
write_prelude(FILE_T out)2061 write_prelude (FILE_T out)
2062 {
2063 indentf (out, snprintf (line, SNPRINTF_SIZE, "/* \"%s\" %s */\n\n", FILE_OBJECT_NAME (&program), PACKAGE_STRING));
2064 if (OPTION_LOCAL (&program)) {
2065 indentf (out, snprintf (line, SNPRINTF_SIZE, "#include \"a68g-config.h\"\n"));
2066 indentf (out, snprintf (line, SNPRINTF_SIZE, "#include \"a68g.h\"\n\n"));
2067 } else {
2068 indentf (out, snprintf (line, SNPRINTF_SIZE, "#include <%s/a68g-config.h>\n", PACKAGE));
2069 indentf (out, snprintf (line, SNPRINTF_SIZE, "#include <%s/a68g.h>\n\n", PACKAGE));
2070 }
2071 indent (out, "#define _CODE_(n) PROP_T n (NODE_T * p) {\\\n");
2072 indent (out, " PROP_T self;\n\n");
2073 indent (out, "#define _EDOC_(n, q) UNIT (&self) = n;\\\n");
2074 indent (out, " SOURCE (&self) = q;\\\n");
2075 indent (out, " (void) p;\\\n");
2076 indent (out, " return (self);}\n\n");
2077 indent (out, "#define DIV_INT(i, j) ((double) (i) / (double) (j))\n");
2078 indent (out, "#define _N_(n) (node_register[n])\n");
2079 indent (out, "#define _S_(z) (STATUS (z))\n");
2080 indent (out, "#define _V_(z) (VALUE (z))\n\n");
2081 }
2082
2083 /**
2084 @brief Write initialisation of frame.
2085 **/
2086
2087 static void
init_static_frame(FILE_T out,NODE_T * p)2088 init_static_frame (FILE_T out, NODE_T * p)
2089 {
2090 if (AP_INCREMENT (TABLE (p)) > 0) {
2091 indentf (out, snprintf (line, SNPRINTF_SIZE, "FRAME_CLEAR (%d);\n", AP_INCREMENT (TABLE (p))));
2092 }
2093 if (LEX_LEVEL (p) == global_level) {
2094 indent (out, "global_pointer = frame_pointer;\n");
2095 }
2096 if (need_initialise_frame (p)) {
2097 indentf (out, snprintf (line, SNPRINTF_SIZE, "initialise_frame (_N_ (%d));\n", NUMBER (p)));
2098 }
2099 }
2100
2101 /********************************/
2102 /* COMPILATION OF PARTIAL UNITS */
2103 /********************************/
2104
2105 /**
2106 @brief Code getting objects from the stack.
2107 @param p Node in syntax tree.
2108 @param out Output file descriptor.
2109 @param dst Where to store.
2110 @param cast Mode to cast to.
2111 **/
2112
2113 static void
get_stack(NODE_T * p,FILE_T out,char * dst,char * cast)2114 get_stack (NODE_T * p, FILE_T out, char *dst, char *cast)
2115 {
2116 if (DEBUG_LEVEL >= 4) {
2117 if (LEVEL (GINFO (p)) == global_level) {
2118 indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_GLOBAL (%s, %s, %d);\n", dst, cast, OFFSET (TAX (p))));
2119 } else {
2120 indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, %d);\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p))));
2121 }
2122 } else {
2123 indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, %d);\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p))));
2124 }
2125 }
2126
2127 /**
2128 @brief Code function prelude.
2129 @param out Output file descriptor.
2130 @param p Node in syntax tree.
2131 @param fn Function name.
2132 **/
2133
2134 static void
write_fun_prelude(NODE_T * p,FILE_T out,char * fn)2135 write_fun_prelude (NODE_T * p, FILE_T out, char *fn)
2136 {
2137 (void) p;
2138 indentf (out, snprintf (line, SNPRINTF_SIZE, "_CODE_ (%s)\n", fn));
2139 indentation++;
2140 temp_book_pointer = 0;
2141 }
2142
2143 /**
2144 @brief Code function postlude.
2145 @param out Output file descriptor.
2146 @param p Node in syntax tree.
2147 @param fn Function name.
2148 **/
2149
2150 static void
write_fun_postlude(NODE_T * p,FILE_T out,char * fn)2151 write_fun_postlude (NODE_T * p, FILE_T out, char *fn)
2152 {
2153 (void) p;
2154 indentation--;
2155 indentf (out, snprintf (line, SNPRINTF_SIZE, "_EDOC_ (%s, _N_ (%d))\n\n", fn, NUMBER (p)));
2156 temp_book_pointer = 0;
2157 }
2158
2159 /**
2160 @brief Code internal a68g mode.
2161 @param m Mode to check.
2162 @return See brief description.
2163 **/
2164
2165 static char *
internal_mode(MOID_T * m)2166 internal_mode (MOID_T * m)
2167 {
2168 if (m == MODE (INT)) {
2169 return ("MODE (INT)");
2170 } else if (m == MODE (REAL)) {
2171 return ("MODE (REAL)");
2172 } else if (m == MODE (BOOL)) {
2173 return ("MODE (BOOL)");
2174 } else if (m == MODE (CHAR)) {
2175 return ("MODE (CHAR)");
2176 } else if (m == MODE (BITS)) {
2177 return ("MODE (BITS)");
2178 } else {
2179 return ("MODE (ERROR)");
2180 }
2181 }
2182
2183 /**
2184 @brief Code an A68 mode.
2185 @param m Mode to code.
2186 @return Internal identifier for mode.
2187 **/
2188
2189 static char *
inline_mode(MOID_T * m)2190 inline_mode (MOID_T * m)
2191 {
2192 if (m == MODE (INT)) {
2193 return ("A68_INT");
2194 } else if (m == MODE (REAL)) {
2195 return ("A68_REAL");
2196 } else if (LONG_MODE (m)) {
2197 return ("A68_LONG");
2198 } else if (m == MODE (BOOL)) {
2199 return ("A68_BOOL");
2200 } else if (m == MODE (CHAR)) {
2201 return ("A68_CHAR");
2202 } else if (m == MODE (BITS)) {
2203 return ("A68_BITS");
2204 } else if (m == MODE (COMPLEX)) {
2205 return ("A68_COMPLEX");
2206 } else if (IS (m, REF_SYMBOL)) {
2207 return ("A68_REF");
2208 } else if (IS (m, ROW_SYMBOL)) {
2209 return ("A68_ROW");
2210 } else if (IS (m, PROC_SYMBOL)) {
2211 return ("A68_PROCEDURE");
2212 } else if (IS (m, STRUCT_SYMBOL)) {
2213 return ("A68_STRUCT");
2214 } else {
2215 return ("A68_ERROR");
2216 }
2217 }
2218
2219 /**
2220 @brief Code denotation.
2221 @param p Starting node.
2222 @param out Object file.
2223 @param phase Phase of code generation.
2224 **/
2225
2226 static void
inline_denotation(NODE_T * p,FILE_T out,int phase)2227 inline_denotation (NODE_T * p, FILE_T out, int phase)
2228 {
2229 if (phase == L_DECLARE && LONG_MODE (MOID (p))) {
2230 char acc[NAME_SIZE];
2231 A68_LONG z;
2232 NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p);
2233 int k;
2234 (void) make_name (acc, CON, "", NUMBER (p));
2235 if (genie_string_to_value_internal (p, MOID (p), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
2236 diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (INT));
2237 }
2238 indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_LONG %s = {INIT_MASK, %.0f", acc, z[1]));
2239 for (k = 1; k <= LONG_MP_DIGITS; k++) {
2240 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %.0f", z[k + 1]));
2241 }
2242 undent (out, "};\n");
2243 }
2244 if (phase == L_YIELD) {
2245 if (MOID (p) == MODE (INT)) {
2246 A68_INT z;
2247 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
2248 char *den = NSYMBOL (s);
2249 if (genie_string_to_value_internal (p, MODE (INT), den, (BYTE_T *) & z) == A68_FALSE) {
2250 diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (INT));
2251 }
2252 undentf (out, snprintf (line, SNPRINTF_SIZE, "%d", VALUE (&z)));
2253 } else if (MOID (p) == MODE (REAL)) {
2254 A68_REAL z;
2255 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
2256 char *den = NSYMBOL (s);
2257 if (genie_string_to_value_internal (p, MODE (REAL), den, (BYTE_T *) & z) == A68_FALSE) {
2258 diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (REAL));
2259 }
2260 if (strchr (den, '.') == NO_TEXT && strchr (den, 'e') == NO_TEXT && strchr (den, 'E') == NO_TEXT) {
2261 undentf (out, snprintf (line, SNPRINTF_SIZE, "(double) %s", den));
2262 } else {
2263 undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", den));
2264 }
2265 } else if (LONG_MODE (MOID (p))) {
2266 char acc[NAME_SIZE];
2267 (void) make_name (acc, CON, "", NUMBER (p));
2268 undent (out, acc);
2269 } else if (MOID (p) == MODE (BOOL)) {
2270 undent (out, "(BOOL_T) A68_");
2271 undent (out, NSYMBOL (p));
2272 } else if (MOID (p) == MODE (CHAR)) {
2273 if (NSYMBOL (p)[0] == '\'') {
2274 undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\''"));
2275 } else if (NSYMBOL (p)[0] == NULL_CHAR) {
2276 undentf (out, snprintf (line, SNPRINTF_SIZE, "NULL_CHAR"));
2277 } else if (NSYMBOL (p)[0] == '\\') {
2278 undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\\\'"));
2279 } else {
2280 undentf (out, snprintf (line, SNPRINTF_SIZE, "'%c'", (NSYMBOL (p))[0]));
2281 }
2282 } else if (MOID (p) == MODE (BITS)) {
2283 A68_BITS z;
2284 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
2285 if (genie_string_to_value_internal (p, MODE (BITS), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
2286 diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (BITS));
2287 }
2288 ASSERT (snprintf (line, SNPRINTF_SIZE, "(unsigned) 0x%x", VALUE (&z)) >= 0);
2289 undent (out, line);
2290 }
2291 }
2292 }
2293
2294 /**
2295 @brief Code widening.
2296 @param p Starting node.
2297 @param out Object file.
2298 @param phase Phase of code generation.
2299 **/
2300
2301 static void
inline_widening(NODE_T * p,FILE_T out,int phase)2302 inline_widening (NODE_T * p, FILE_T out, int phase)
2303 {
2304 if (WIDEN_TO (p, INT, REAL)) {
2305 if (phase == L_DECLARE) {
2306 inline_unit (SUB (p), out, L_DECLARE);
2307 } else if (phase == L_EXECUTE) {
2308 inline_unit (SUB (p), out, L_EXECUTE);
2309 } else if (phase == L_YIELD) {
2310 undent (out, "(double) (");
2311 inline_unit (SUB (p), out, L_YIELD);
2312 undent (out, ")");
2313 }
2314 } else if (WIDEN_TO (p, REAL, COMPLEX)) {
2315 char acc[NAME_SIZE];
2316 (void) make_name (acc, TMP, "", NUMBER (p));
2317 if (phase == L_DECLARE) {
2318 (void) add_declaration (&root_idf, inline_mode (MODE (COMPLEX)), 0, acc);
2319 inline_unit (SUB (p), out, L_DECLARE);
2320 } else if (phase == L_EXECUTE) {
2321 inline_unit (SUB (p), out, L_EXECUTE);
2322 indentf (out, snprintf (line, SNPRINTF_SIZE, "STATUS_RE (%s) = INIT_MASK;\n", acc));
2323 indentf (out, snprintf (line, SNPRINTF_SIZE, "STATUS_IM (%s) = INIT_MASK;\n", acc));
2324 indentf (out, snprintf (line, SNPRINTF_SIZE, "RE (%s) = (double) (", acc));
2325 inline_unit (SUB (p), out, L_YIELD);
2326 undent (out, ");\n");
2327 indentf (out, snprintf (line, SNPRINTF_SIZE, "IM (%s) = 0.0;\n", acc));
2328 } else if (phase == L_YIELD) {
2329 undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) %s", acc));
2330 }
2331 } else if (WIDEN_TO (p, INT, LONG_INT)) {
2332 char acc[NAME_SIZE];
2333 (void) make_name (acc, TMP, "", NUMBER (p));
2334 if (phase == L_DECLARE) {
2335 (void) add_declaration (&root_idf, inline_mode (MODE (LONG_INT)), 0, acc);
2336 inline_unit (SUB (p), out, L_DECLARE);
2337 } else if (phase == L_EXECUTE) {
2338 inline_unit (SUB (p), out, L_EXECUTE);
2339 indentf (out, snprintf (line, SNPRINTF_SIZE, "(void) int_to_mp (_N_ (%d), %s, ", NUMBER (p), acc));
2340 inline_unit (SUB (p), out, L_YIELD);
2341 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS));
2342 } else if (phase == L_YIELD) {
2343 undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) %s", acc));
2344 }
2345 } else if (WIDEN_TO (p, REAL, LONG_REAL)) {
2346 char acc[NAME_SIZE];
2347 (void) make_name (acc, TMP, "", NUMBER (p));
2348 if (phase == L_DECLARE) {
2349 (void) add_declaration (&root_idf, inline_mode (MODE (LONG_REAL)), 0, acc);
2350 inline_unit (SUB (p), out, L_DECLARE);
2351 } else if (phase == L_EXECUTE) {
2352 inline_unit (SUB (p), out, L_EXECUTE);
2353 indentf (out, snprintf (line, SNPRINTF_SIZE, "(void) real_to_mp (_N_ (%d), %s, ", NUMBER (p), acc));
2354 inline_unit (SUB (p), out, L_YIELD);
2355 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS));
2356 } else if (phase == L_YIELD) {
2357 undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) %s", acc));
2358 }
2359 } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) {
2360 inline_unit (SUB (p), out, phase);
2361 }
2362 }
2363
2364 /**
2365 @brief Code dereferencing of identifier.
2366 @param p Starting node.
2367 @param out Object file.
2368 @param phase Phase of code generation.
2369 **/
2370
2371 static void
inline_dereference_identifier(NODE_T * p,FILE_T out,int phase)2372 inline_dereference_identifier (NODE_T * p, FILE_T out, int phase)
2373 {
2374 NODE_T *q = locate (SUB (p), IDENTIFIER);
2375 ABEND (q == NO_NODE, "not dereferencing an identifier", NO_TEXT);
2376 if (phase == L_DECLARE) {
2377 if (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)) != NO_BOOK) {
2378 return;
2379 } else {
2380 char idf[NAME_SIZE];
2381 (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
2382 (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, idf);
2383 sign_in (BOOK_DEREF, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p));
2384 inline_unit (SUB (p), out, L_DECLARE);
2385 }
2386 } else if (phase == L_EXECUTE) {
2387 if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) != NO_BOOK) {
2388 return;
2389 } else {
2390 char idf[NAME_SIZE];
2391 (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
2392 inline_unit (SUB (p), out, L_EXECUTE);
2393 if (BODY (TAX (q)) != NO_TAG) {
2394 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) LOCAL_ADDRESS (", idf, inline_mode (MOID (p))));
2395 sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
2396 inline_unit (SUB (p), out, L_YIELD);
2397 undent (out, ");\n");
2398 } else {
2399 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, ", idf, inline_mode (MOID (p))));
2400 sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
2401 inline_unit (SUB (p), out, L_YIELD);
2402 undent (out, ");\n");
2403 }
2404 }
2405 } else if (phase == L_YIELD) {
2406 char idf[NAME_SIZE];
2407 if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) != NO_BOOK) {
2408 (void) make_name (idf, NSYMBOL (q), "", NUMBER (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q))));
2409 } else {
2410 (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
2411 }
2412 if (primitive_mode (MOID (p))) {
2413 undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", idf));
2414 } else if (MOID (p) == MODE (COMPLEX)) {
2415 undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf));
2416 } else if (LONG_MODE (MOID (p))) {
2417 undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", idf));
2418 } else if (basic_mode (MOID (p))) {
2419 undent (out, idf);
2420 }
2421 }
2422 }
2423
2424 /**
2425 @brief Code identifier.
2426 @param p Starting node.
2427 @param out Object file.
2428 @param phase Phase of code generation.
2429 **/
2430
2431 static void
inline_identifier(NODE_T * p,FILE_T out,int phase)2432 inline_identifier (NODE_T * p, FILE_T out, int phase)
2433 {
2434 /* Possible constant folding */
2435 NODE_T *def = NODE (TAX (p));
2436 if (primitive_mode (MOID (p)) && def != NO_NODE && NEXT (def) != NO_NODE && IS (NEXT (def), EQUALS_SYMBOL)) {
2437 NODE_T *src = locate (NEXT_NEXT (def), DENOTATION);
2438 if (src != NO_NODE) {
2439 inline_denotation (src, out, phase);
2440 return;
2441 }
2442 }
2443 /* No folding - consider identifier */
2444 if (phase == L_DECLARE) {
2445 if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (p)) != NO_BOOK) {
2446 return;
2447 } else if (A68G_STANDENV_PROC (TAX (p))) {
2448 return;
2449 } else {
2450 char idf[NAME_SIZE];
2451 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
2452 (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, idf);
2453 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p));
2454 }
2455 } else if (phase == L_EXECUTE) {
2456 if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)) != NO_BOOK) {
2457 return;
2458 } else if (A68G_STANDENV_PROC (TAX (p))) {
2459 return;
2460 } else {
2461 char idf[NAME_SIZE];
2462 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
2463 get_stack (p, out, idf, inline_mode (MOID (p)));
2464 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
2465 }
2466 } else if (phase == L_YIELD) {
2467 if (A68G_STANDENV_PROC (TAX (p))) {
2468 int k;
2469 for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
2470 if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
2471 undent (out, CODE (&constants[k]));
2472 return;
2473 }
2474 }
2475 } else {
2476 char idf[NAME_SIZE];
2477 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p));
2478 if (entry != NO_BOOK) {
2479 (void) make_name (idf, NSYMBOL (p), "", NUMBER (entry));
2480 } else {
2481 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
2482 }
2483 if (primitive_mode (MOID (p))) {
2484 undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", idf));
2485 } else if (MOID (p) == MODE (COMPLEX)) {
2486 undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf));
2487 } else if (LONG_MODE (MOID (p))) {
2488 undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", idf));
2489 } else if (basic_mode (MOID (p))) {
2490 undent (out, idf);
2491 }
2492 }
2493 }
2494 }
2495
2496 /**
2497 @brief Code indexer.
2498 @param p Starting node.
2499 @param out Object file.
2500 @param phase Phase of code generation.
2501 @param k Counter.
2502 @param tup Tuple pointer.
2503 **/
2504
2505 static void
inline_indexer(NODE_T * p,FILE_T out,int phase,int * k,char * tup)2506 inline_indexer (NODE_T * p, FILE_T out, int phase, int *k, char *tup)
2507 {
2508 if (p == NO_NODE) {
2509 return;
2510 } else if (IS (p, UNIT)) {
2511 if (phase != L_YIELD) {
2512 inline_unit (p, out, phase);
2513 } else {
2514 if ((*k) == 0) {
2515 undentf (out, snprintf (line, SNPRINTF_SIZE, "(SPAN (&%s[%d]) * (", tup, (*k)));
2516 } else {
2517 undentf (out, snprintf (line, SNPRINTF_SIZE, " + (SPAN (&%s[%d]) * (", tup, (*k)));
2518 }
2519 inline_unit (p, out, L_YIELD);
2520 undentf (out, snprintf (line, SNPRINTF_SIZE, ") - SHIFT (&%s[%d]))", tup, (*k)));
2521 }
2522 (*k)++;
2523 } else {
2524 inline_indexer (SUB (p), out, phase, k, tup);
2525 inline_indexer (NEXT (p), out, phase, k, tup);
2526 }
2527 }
2528
2529 /**
2530 @brief Code dereferencing of slice.
2531 @param p Starting node.
2532 @param out Object file.
2533 @param phase Phase of code generation.
2534 **/
2535
2536 static void
inline_dereference_slice(NODE_T * p,FILE_T out,int phase)2537 inline_dereference_slice (NODE_T * p, FILE_T out, int phase)
2538 {
2539 NODE_T *prim = SUB (p);
2540 NODE_T *indx = NEXT (prim);
2541 MOID_T *row_mode = DEFLEX (MOID (prim));
2542 MOID_T *mode = SUB_SUB (row_mode);
2543 char *symbol = NSYMBOL (SUB (prim));
2544 char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE];
2545 int k;
2546 if (phase == L_DECLARE) {
2547 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, symbol);
2548 if (entry == NO_BOOK) {
2549 (void) make_name (idf, symbol, "", NUMBER (prim));
2550 (void) make_name (arr, ARR, "", NUMBER (prim));
2551 (void) make_name (tup, TUP, "", NUMBER (prim));
2552 (void) make_name (elm, ELM, "", NUMBER (prim));
2553 (void) make_name (drf, DRF, "", NUMBER (prim));
2554 (void) add_declaration (&root_idf, "A68_REF", 1, idf);
2555 (void) add_declaration (&root_idf, "A68_REF", 0, elm);
2556 (void) add_declaration (&root_idf, "A68_ARRAY", 1, arr);
2557 (void) add_declaration (&root_idf, "A68_TUPLE", 1, tup);
2558 (void) add_declaration (&root_idf, inline_mode (mode), 1, drf);
2559 sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
2560 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
2561 (void) make_name (elm, ELM, "", NUMBER (prim));
2562 (void) make_name (drf, DRF, "", NUMBER (prim));
2563 (void) add_declaration (&root_idf, "A68_REF", 0, elm);
2564 (void) add_declaration (&root_idf, inline_mode (mode), 1, drf);
2565 }
2566 k = 0;
2567 inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
2568 } else if (phase == L_EXECUTE) {
2569 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
2570 NODE_T *pidf = locate (prim, IDENTIFIER);
2571 if (entry == NO_BOOK) {
2572 (void) make_name (idf, symbol, "", NUMBER (prim));
2573 (void) make_name (arr, ARR, "", NUMBER (prim));
2574 (void) make_name (tup, TUP, "", NUMBER (prim));
2575 (void) make_name (elm, ELM, "", NUMBER (prim));
2576 (void) make_name (drf, DRF, "", NUMBER (prim));
2577 get_stack (pidf, out, idf, "A68_REF");
2578 if (IS (row_mode, REF_SYMBOL) && IS (SUB (row_mode), ROW_SYMBOL)) {
2579 indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
2580 } else {
2581 ABEND (A68_TRUE, "strange mode in dereference slice (execute)", NO_TEXT);
2582 }
2583 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
2584 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
2585 (void) make_name (arr, ARR, "", NUMBER (entry));
2586 (void) make_name (tup, TUP, "", NUMBER (entry));
2587 (void) make_name (elm, ELM, "", NUMBER (prim));
2588 (void) make_name (drf, DRF, "", NUMBER (prim));
2589 } else {
2590 return;
2591 }
2592 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
2593 k = 0;
2594 inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
2595 indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
2596 k = 0;
2597 inline_indexer (indx, out, L_YIELD, &k, tup);
2598 undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n"));
2599 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
2600 } else if (phase == L_YIELD) {
2601 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
2602 if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) {
2603 (void) make_name (drf, DRF, "", NUMBER (entry));
2604 } else {
2605 (void) make_name (drf, DRF, "", NUMBER (prim));
2606 }
2607 if (primitive_mode (mode)) {
2608 undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", drf));
2609 } else if (mode == MODE (COMPLEX)) {
2610 undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf));
2611 } else if (LONG_MODE (mode)) {
2612 undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", drf));
2613 } else if (basic_mode (mode)) {
2614 undent (out, drf);
2615 } else {
2616 ABEND (A68_TRUE, "strange mode in dereference slice (yield)", NO_TEXT);
2617 }
2618 }
2619 }
2620
2621 /**
2622 @brief Code slice REF [] MODE -> REF MODE.
2623 @param p Starting node.
2624 @param out Object file.
2625 @param phase Phase of code generation.
2626 **/
2627
2628 static void
inline_slice_ref_to_ref(NODE_T * p,FILE_T out,int phase)2629 inline_slice_ref_to_ref (NODE_T * p, FILE_T out, int phase)
2630 {
2631 NODE_T *prim = SUB (p);
2632 NODE_T *indx = NEXT (prim);
2633 MOID_T *mode = SUB_MOID (p);
2634 MOID_T *row_mode = DEFLEX (MOID (prim));
2635 char *symbol = NSYMBOL (SUB (prim));
2636 char idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE], drf[NAME_SIZE];
2637 int k;
2638 if (phase == L_DECLARE) {
2639 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, symbol);
2640 if (entry == NO_BOOK) {
2641 (void) make_name (idf, symbol, "", NUMBER (prim));
2642 (void) make_name (arr, ARR, "", NUMBER (prim));
2643 (void) make_name (tup, TUP, "", NUMBER (prim));
2644 (void) make_name (elm, ELM, "", NUMBER (prim));
2645 (void) make_name (drf, DRF, "", NUMBER (prim));
2646 /*indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF * %s, %s; %s * %s; A68_ARRAY * %s; A68_TUPLE * %s;\n", idf, elm, inline_mode (mode), drf, arr, tup)); */
2647 (void) add_declaration (&root_idf, "A68_REF", 1, idf);
2648 (void) add_declaration (&root_idf, "A68_REF", 0, elm);
2649 (void) add_declaration (&root_idf, "A68_ARRAY", 1, arr);
2650 (void) add_declaration (&root_idf, "A68_TUPLE", 1, tup);
2651 (void) add_declaration (&root_idf, inline_mode (mode), 1, drf);
2652 sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
2653 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
2654 (void) make_name (elm, ELM, "", NUMBER (prim));
2655 (void) make_name (drf, DRF, "", NUMBER (prim));
2656 /*indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF %s; %s * %s;\n", elm, inline_mode (mode), drf)); */
2657 (void) add_declaration (&root_idf, "A68_REF", 0, elm);
2658 (void) add_declaration (&root_idf, inline_mode (mode), 1, drf);
2659 }
2660 k = 0;
2661 inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
2662 } else if (phase == L_EXECUTE) {
2663 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
2664 if (entry == NO_BOOK) {
2665 NODE_T *pidf = locate (prim, IDENTIFIER);
2666 (void) make_name (idf, symbol, "", NUMBER (prim));
2667 (void) make_name (arr, ARR, "", NUMBER (prim));
2668 (void) make_name (tup, TUP, "", NUMBER (prim));
2669 (void) make_name (elm, ELM, "", NUMBER (prim));
2670 (void) make_name (drf, DRF, "", NUMBER (prim));
2671 get_stack (pidf, out, idf, "A68_REF");
2672 if (IS (row_mode, REF_SYMBOL) && IS (SUB (row_mode), ROW_SYMBOL)) {
2673 indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
2674 } else {
2675 ABEND (A68_TRUE, "strange mode in slice (execute)", NO_TEXT);
2676 }
2677 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
2678 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
2679 (void) make_name (arr, ARR, "", NUMBER (entry));
2680 (void) make_name (tup, TUP, "", NUMBER (entry));
2681 (void) make_name (elm, ELM, "", NUMBER (prim));
2682 (void) make_name (drf, DRF, "", NUMBER (prim));
2683 } else {
2684 return;
2685 }
2686 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
2687 k = 0;
2688 inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
2689 indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
2690 k = 0;
2691 inline_indexer (indx, out, L_YIELD, &k, tup);
2692 undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n"));
2693 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
2694 } else if (phase == L_YIELD) {
2695 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
2696 if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) {
2697 (void) make_name (elm, ELM, "", NUMBER (entry));
2698 } else {
2699 (void) make_name (elm, ELM, "", NUMBER (prim));
2700 }
2701 undentf (out, snprintf (line, SNPRINTF_SIZE, "(&%s)", elm));
2702 }
2703 }
2704
2705 /**
2706 @brief Code slice [] MODE -> MODE.
2707 @param p Starting node.
2708 @param out Object file.
2709 @param phase Phase of code generation.
2710 **/
2711
2712 static void
inline_slice(NODE_T * p,FILE_T out,int phase)2713 inline_slice (NODE_T * p, FILE_T out, int phase)
2714 {
2715 NODE_T *prim = SUB (p);
2716 NODE_T *indx = NEXT (prim);
2717 MOID_T *mode = MOID (p);
2718 MOID_T *row_mode = DEFLEX (MOID (prim));
2719 char *symbol = NSYMBOL (SUB (prim));
2720 char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE];
2721 int k;
2722 if (phase == L_DECLARE) {
2723 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, symbol);
2724 if (entry == NO_BOOK) {
2725 (void) make_name (idf, symbol, "", NUMBER (prim));
2726 (void) make_name (arr, ARR, "", NUMBER (prim));
2727 (void) make_name (tup, TUP, "", NUMBER (prim));
2728 (void) make_name (elm, ELM, "", NUMBER (prim));
2729 (void) make_name (drf, DRF, "", NUMBER (prim));
2730 indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF * %s, %s; %s * %s; A68_ARRAY * %s; A68_TUPLE * %s;\n", idf, elm, inline_mode (mode), drf, arr, tup));
2731 sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
2732 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
2733 (void) make_name (elm, ELM, "", NUMBER (prim));
2734 (void) make_name (drf, DRF, "", NUMBER (prim));
2735 indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF %s; %s * %s;\n", elm, inline_mode (mode), drf));
2736 }
2737 k = 0;
2738 inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
2739 } else if (phase == L_EXECUTE) {
2740 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
2741 if (entry == NO_BOOK) {
2742 NODE_T *pidf = locate (prim, IDENTIFIER);
2743 (void) make_name (idf, symbol, "", NUMBER (prim));
2744 (void) make_name (arr, ARR, "", NUMBER (prim));
2745 (void) make_name (tup, TUP, "", NUMBER (prim));
2746 (void) make_name (elm, ELM, "", NUMBER (prim));
2747 (void) make_name (drf, DRF, "", NUMBER (prim));
2748 get_stack (pidf, out, idf, "A68_REF");
2749 if (IS (row_mode, REF_SYMBOL)) {
2750 indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
2751 } else {
2752 indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, (A68_ROW *) %s);\n", arr, tup, idf));
2753 }
2754 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
2755 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
2756 (void) make_name (arr, ARR, "", NUMBER (entry));
2757 (void) make_name (tup, TUP, "", NUMBER (entry));
2758 (void) make_name (elm, ELM, "", NUMBER (prim));
2759 (void) make_name (drf, DRF, "", NUMBER (prim));
2760 } else {
2761 return;
2762 }
2763 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
2764 k = 0;
2765 inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
2766 indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
2767 k = 0;
2768 inline_indexer (indx, out, L_YIELD, &k, tup);
2769 undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n"));
2770 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
2771 } else if (phase == L_YIELD) {
2772 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
2773 if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) {
2774 (void) make_name (drf, DRF, "", NUMBER (entry));
2775 } else {
2776 (void) make_name (drf, DRF, "", NUMBER (prim));
2777 }
2778 if (primitive_mode (mode)) {
2779 undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", drf));
2780 } else if (mode == MODE (COMPLEX)) {
2781 undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf));
2782 } else if (LONG_MODE (mode)) {
2783 undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", drf));
2784 } else if (basic_mode (mode)) {
2785 undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", drf));
2786 } else {
2787 ABEND (A68_TRUE, "strange mode in slice (yield)", NO_TEXT);
2788 }
2789 }
2790 }
2791
2792 /**
2793 @brief Code monadic formula.
2794 @param p Starting node.
2795 @param out Object file.
2796 @param phase Phase of code generation.
2797 **/
2798
2799 static void
inline_monadic_formula(NODE_T * p,FILE_T out,int phase)2800 inline_monadic_formula (NODE_T * p, FILE_T out, int phase)
2801 {
2802 NODE_T *op = SUB (p);
2803 NODE_T *rhs = NEXT (op);
2804 if (IS (p, MONADIC_FORMULA) && MOID (p) == MODE (COMPLEX)) {
2805 char acc[NAME_SIZE];
2806 (void) make_name (acc, TMP, "", NUMBER (p));
2807 if (phase == L_DECLARE) {
2808 (void) add_declaration (&root_idf, inline_mode (MODE (COMPLEX)), 0, acc);
2809 inline_unit (rhs, out, L_DECLARE);
2810 } else if (phase == L_EXECUTE) {
2811 int k;
2812 inline_unit (rhs, out, L_EXECUTE);
2813 for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
2814 if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
2815 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (%s, ", CODE (&monadics[k]), acc));
2816 inline_unit (rhs, out, L_YIELD);
2817 undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n"));
2818 }
2819 }
2820 } else if (phase == L_YIELD) {
2821 undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc));
2822 }
2823 } else if (IS (p, MONADIC_FORMULA) && LONG_MODE (MOID (rhs))) {
2824 char acc[NAME_SIZE];
2825 (void) make_name (acc, TMP, "", NUMBER (p));
2826 if (phase == L_DECLARE) {
2827 (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc);
2828 inline_unit (rhs, out, L_DECLARE);
2829 } else if (phase == L_EXECUTE) {
2830 int k;
2831 inline_unit (rhs, out, L_EXECUTE);
2832 for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
2833 if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
2834 if (LONG_MODE (MOID (p))) {
2835 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), %s, ", CODE (&monadics[k]), NUMBER (op), acc));
2836 } else {
2837 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), & %s, ", CODE (&monadics[k]), NUMBER (op), acc));
2838 }
2839 inline_unit (rhs, out, L_YIELD);
2840 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS));
2841 }
2842 }
2843 } else if (phase == L_YIELD) {
2844 undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc));
2845 }
2846 } else if (IS (p, MONADIC_FORMULA) && basic_mode (MOID (p))) {
2847 if (phase != L_YIELD) {
2848 inline_unit (rhs, out, phase);
2849 } else {
2850 int k;
2851 for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
2852 if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
2853 if (IS_ALNUM ((CODE (&monadics[k]))[0])) {
2854 undent (out, CODE (&monadics[k]));
2855 undent (out, "(");
2856 inline_unit (rhs, out, L_YIELD);
2857 undent (out, ")");
2858 } else {
2859 undent (out, CODE (&monadics[k]));
2860 undent (out, "(");
2861 inline_unit (rhs, out, L_YIELD);
2862 undent (out, ")");
2863 }
2864 }
2865 }
2866 }
2867 }
2868 }
2869
2870 /**
2871 @brief Code dyadic formula.
2872 @param p Starting node.
2873 @param out Object file.
2874 @param phase Phase of code generation.
2875 **/
2876
2877 static void
inline_formula(NODE_T * p,FILE_T out,int phase)2878 inline_formula (NODE_T * p, FILE_T out, int phase)
2879 {
2880 NODE_T *lhs = SUB (p), *rhs;
2881 NODE_T *op = NEXT (lhs);
2882 if (IS (p, FORMULA) && op == NO_NODE) {
2883 inline_monadic_formula (lhs, out, phase);
2884 return;
2885 }
2886 rhs = NEXT (op);
2887 if (IS (p, FORMULA) && MOID (p) == MODE (COMPLEX)) {
2888 if (op == NO_NODE) {
2889 inline_monadic_formula (lhs, out, phase);
2890 } else if (phase == L_DECLARE) {
2891 char acc[NAME_SIZE];
2892 (void) make_name (acc, TMP, "", NUMBER (p));
2893 (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc);
2894 inline_unit (lhs, out, L_DECLARE);
2895 inline_unit (rhs, out, L_DECLARE);
2896 } else if (phase == L_EXECUTE) {
2897 char acc[NAME_SIZE];
2898 int k;
2899 (void) make_name (acc, TMP, "", NUMBER (p));
2900 inline_unit (lhs, out, L_EXECUTE);
2901 inline_unit (rhs, out, L_EXECUTE);
2902 for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
2903 if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
2904 if (MOID (p) == MODE (COMPLEX)) {
2905 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (%s, ", CODE (&dyadics[k]), acc));
2906 } else {
2907 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (& %s, ", CODE (&dyadics[k]), acc));
2908 }
2909 inline_unit (lhs, out, L_YIELD);
2910 undentf (out, snprintf (line, SNPRINTF_SIZE, ", "));
2911 inline_unit (rhs, out, L_YIELD);
2912 undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n"));
2913 }
2914 }
2915 } else if (phase == L_YIELD) {
2916 char acc[NAME_SIZE];
2917 (void) make_name (acc, TMP, "", NUMBER (p));
2918 if (MOID (p) == MODE (COMPLEX)) {
2919 undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc));
2920 } else {
2921 undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (& %s)", acc));
2922 }
2923 }
2924 } else if (IS (p, FORMULA) && LONG_MODE (MOID (lhs)) && LONG_MODE (MOID (rhs))) {
2925 char acc[NAME_SIZE];
2926 (void) make_name (acc, TMP, "", NUMBER (p));
2927 if (phase == L_DECLARE) {
2928 (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc);
2929 inline_unit (lhs, out, L_DECLARE);
2930 inline_unit (rhs, out, L_DECLARE);
2931 } else if (phase == L_EXECUTE) {
2932 int k;
2933 inline_unit (lhs, out, L_EXECUTE);
2934 inline_unit (rhs, out, L_EXECUTE);
2935 for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
2936 if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
2937 if (LONG_MODE (MOID (p))) {
2938 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), %s, ", CODE (&dyadics[k]), NUMBER (op), acc));
2939 } else {
2940 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), & %s, ", CODE (&dyadics[k]), NUMBER (op), acc));
2941 }
2942 inline_unit (lhs, out, L_YIELD);
2943 undentf (out, snprintf (line, SNPRINTF_SIZE, ", "));
2944 inline_unit (rhs, out, L_YIELD);
2945 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS));
2946 }
2947 }
2948 } else if (phase == L_YIELD) {
2949 if (LONG_MODE (MOID (p))) {
2950 undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc));
2951 } else {
2952 undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (& %s)", acc));
2953 }
2954 }
2955 } else if (IS (p, FORMULA) && basic_mode (MOID (p))) {
2956 if (phase != L_YIELD) {
2957 inline_unit (lhs, out, phase);
2958 inline_unit (rhs, out, phase);
2959 } else {
2960 int k;
2961 for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
2962 if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
2963 if (IS_ALNUM ((CODE (&dyadics[k]))[0])) {
2964 undent (out, CODE (&dyadics[k]));
2965 undent (out, "(");
2966 inline_unit (lhs, out, L_YIELD);
2967 undent (out, ", ");
2968 inline_unit (rhs, out, L_YIELD);
2969 undent (out, ")");
2970 } else {
2971 undent (out, "(");
2972 inline_unit (lhs, out, L_YIELD);
2973 undent (out, " ");
2974 undent (out, CODE (&dyadics[k]));
2975 undent (out, " ");
2976 inline_unit (rhs, out, L_YIELD);
2977 undent (out, ")");
2978 }
2979 }
2980 }
2981 }
2982 }
2983 }
2984
2985 /**
2986 @brief Code argument.
2987 @param p Starting node.
2988 @param out Output file descriptor.
2989 @param phase Phase of code generation.
2990 @return See brief description.
2991 **/
2992
2993 static void
inline_single_argument(NODE_T * p,FILE_T out,int phase)2994 inline_single_argument (NODE_T * p, FILE_T out, int phase)
2995 {
2996 for (; p != NO_NODE; FORWARD (p)) {
2997 if (IS (p, ARGUMENT_LIST) || IS (p, ARGUMENT)) {
2998 inline_single_argument (SUB (p), out, phase);
2999 } else if (IS (p, GENERIC_ARGUMENT_LIST) || IS (p, GENERIC_ARGUMENT)) {
3000 inline_single_argument (SUB (p), out, phase);
3001 } else if (IS (p, UNIT)) {
3002 inline_unit (p, out, phase);
3003 }
3004 }
3005 }
3006
3007 /**
3008 @brief Code call.
3009 @param p Starting node.
3010 @param out Output file descriptor.
3011 @param phase Phase of code generation.
3012 @return See brief description.
3013 **/
3014
3015 static void
inline_call(NODE_T * p,FILE_T out,int phase)3016 inline_call (NODE_T * p, FILE_T out, int phase)
3017 {
3018 NODE_T *prim = SUB (p);
3019 NODE_T *args = NEXT (prim);
3020 NODE_T *idf = locate (prim, IDENTIFIER);
3021 if (MOID (p) == MODE (COMPLEX)) {
3022 char acc[NAME_SIZE];
3023 (void) make_name (acc, TMP, "", NUMBER (p));
3024 if (phase == L_DECLARE) {
3025 (void) add_declaration (&root_idf, inline_mode (MODE (COMPLEX)), 0, acc);
3026 inline_single_argument (args, out, L_DECLARE);
3027 } else if (phase == L_EXECUTE) {
3028 int k;
3029 inline_single_argument (args, out, L_EXECUTE);
3030 for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
3031 if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
3032 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (%s, ", CODE (&functions[k]), acc));
3033 inline_single_argument (args, out, L_YIELD);
3034 undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n"));
3035 }
3036 }
3037 } else if (phase == L_YIELD) {
3038 undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc));
3039 }
3040 } else if (LONG_MODE (MOID (p))) {
3041 char acc[NAME_SIZE];
3042 (void) make_name (acc, TMP, "", NUMBER (p));
3043 if (phase == L_DECLARE) {
3044 (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc);
3045 inline_single_argument (args, out, L_DECLARE);
3046 } else if (phase == L_EXECUTE) {
3047 int k;
3048 inline_single_argument (args, out, L_EXECUTE);
3049 for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
3050 if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
3051 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), %s, ", CODE (&functions[k]), NUMBER (idf), acc));
3052 inline_single_argument (args, out, L_YIELD);
3053 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS));
3054 }
3055 }
3056 } else if (phase == L_YIELD) {
3057 undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc));
3058 }
3059 } else if (basic_mode (MOID (p))) {
3060 if (phase != L_YIELD) {
3061 inline_single_argument (args, out, phase);
3062 } else {
3063 int k;
3064 for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
3065 if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
3066 undent (out, CODE (&functions[k]));
3067 undent (out, " (");
3068 inline_single_argument (args, out, L_YIELD);
3069 undent (out, ")");
3070 }
3071 }
3072 }
3073 }
3074 }
3075
3076 /**
3077 @brief Code collateral units.
3078 @param out Output file descriptor.
3079 @param p Starting node.
3080 @param phase Phase of compilation.
3081 **/
3082
3083 static void
inline_collateral_units(NODE_T * p,FILE_T out,int phase)3084 inline_collateral_units (NODE_T * p, FILE_T out, int phase)
3085 {
3086 if (p == NO_NODE) {
3087 return;
3088 } else if (IS (p, UNIT)) {
3089 if (phase == L_DECLARE) {
3090 inline_unit (SUB (p), out, L_DECLARE);
3091 } else if (phase == L_EXECUTE) {
3092 inline_unit (SUB (p), out, L_EXECUTE);
3093 } else if (phase == L_YIELD) {
3094 indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, "));
3095 inline_unit (SUB (p), out, L_YIELD);
3096 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
3097 }
3098 } else {
3099 inline_collateral_units (SUB (p), out, phase);
3100 inline_collateral_units (NEXT (p), out, phase);
3101 }
3102 }
3103
3104 /**
3105 @brief Code collateral units.
3106 @param out Output file descriptor.
3107 @param p Starting node.
3108 @param phase Compilation phase.
3109 **/
3110
3111 static void
inline_collateral(NODE_T * p,FILE_T out,int phase)3112 inline_collateral (NODE_T * p, FILE_T out, int phase)
3113 {
3114 char dsp[NAME_SIZE];
3115 (void) make_name (dsp, DSP, "", NUMBER (p));
3116 if (p == NO_NODE) {
3117 return;
3118 } else if (phase == L_DECLARE) {
3119 if (MOID (p) == MODE (COMPLEX)) {
3120 (void) add_declaration (&root_idf, inline_mode (MODE (REAL)), 1, dsp);
3121 } else {
3122 (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, dsp);
3123 }
3124 inline_collateral_units (NEXT_SUB (p), out, L_DECLARE);
3125 } else if (phase == L_EXECUTE) {
3126 if (MOID (p) == MODE (COMPLEX)) {
3127 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (MODE (REAL))));
3128 } else {
3129 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (MOID (p))));
3130 }
3131 inline_collateral_units (NEXT_SUB (p), out, L_EXECUTE);
3132 inline_collateral_units (NEXT_SUB (p), out, L_YIELD);
3133 } else if (phase == L_YIELD) {
3134 undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", dsp));
3135 }
3136 }
3137
3138 /**
3139 @brief Code basic closed clause.
3140 @param p Starting node.
3141 @param out Object file.
3142 @param phase Phase of code generation.
3143 **/
3144
3145 static void
inline_closed(NODE_T * p,FILE_T out,int phase)3146 inline_closed (NODE_T * p, FILE_T out, int phase)
3147 {
3148 if (p == NO_NODE) {
3149 return;
3150 } else if (phase != L_YIELD) {
3151 inline_unit (SUB (NEXT_SUB (p)), out, phase);
3152 } else {
3153 undent (out, "(");
3154 inline_unit (SUB (NEXT_SUB (p)), out, L_YIELD);
3155 undent (out, ")");
3156 }
3157 }
3158
3159 /**
3160 @brief Code basic closed clause.
3161 @param p Starting node.
3162 @param out Object file.
3163 @param phase Phase of code generation.
3164 **/
3165
3166 static void
inline_conditional(NODE_T * p,FILE_T out,int phase)3167 inline_conditional (NODE_T * p, FILE_T out, int phase)
3168 {
3169 NODE_T *if_part = NO_NODE, *then_part = NO_NODE, *else_part = NO_NODE;
3170 p = SUB (p);
3171 if (IS (p, IF_PART) || IS (p, OPEN_PART)) {
3172 if_part = p;
3173 } else {
3174 ABEND (A68_TRUE, "if-part expected", NO_TEXT);
3175 }
3176 FORWARD (p);
3177 if (IS (p, THEN_PART) || IS (p, CHOICE)) {
3178 then_part = p;
3179 } else {
3180 ABEND (A68_TRUE, "then-part expected", NO_TEXT);
3181 }
3182 FORWARD (p);
3183 if (IS (p, ELSE_PART) || IS (p, CHOICE)) {
3184 else_part = p;
3185 } else {
3186 else_part = NO_NODE;
3187 }
3188 if (phase == L_DECLARE) {
3189 inline_unit (SUB (NEXT_SUB (if_part)), out, L_DECLARE);
3190 inline_unit (SUB (NEXT_SUB (then_part)), out, L_DECLARE);
3191 inline_unit (SUB (NEXT_SUB (else_part)), out, L_DECLARE);
3192 } else if (phase == L_EXECUTE) {
3193 inline_unit (SUB (NEXT_SUB (if_part)), out, L_EXECUTE);
3194 inline_unit (SUB (NEXT_SUB (then_part)), out, L_EXECUTE);
3195 inline_unit (SUB (NEXT_SUB (else_part)), out, L_EXECUTE);
3196 } else if (phase == L_YIELD) {
3197 undent (out, "(");
3198 inline_unit (SUB (NEXT_SUB (if_part)), out, L_YIELD);
3199 undent (out, " ? ");
3200 inline_unit (SUB (NEXT_SUB (then_part)), out, L_YIELD);
3201 undent (out, " : ");
3202 if (else_part != NO_NODE) {
3203 inline_unit (SUB (NEXT_SUB (else_part)), out, L_YIELD);
3204 } else {
3205 /*
3206 This is not an ideal solution although RR permits it;
3207 an omitted else-part means SKIP: yield some value of the
3208 mode required.
3209 */
3210 inline_unit (SUB (NEXT_SUB (then_part)), out, L_YIELD);
3211 }
3212 undent (out, ")");
3213 }
3214 }
3215
3216 /**
3217 @brief Code dereferencing of selection.
3218 @param p Starting node.
3219 @param out Object file.
3220 @param phase Phase of code generation.
3221 **/
3222
3223 static void
inline_dereference_selection(NODE_T * p,FILE_T out,int phase)3224 inline_dereference_selection (NODE_T * p, FILE_T out, int phase)
3225 {
3226 NODE_T *field = SUB (p);
3227 NODE_T *sec = NEXT (field);
3228 NODE_T *idf = locate (sec, IDENTIFIER);
3229 char ref[NAME_SIZE], sel[NAME_SIZE];
3230 char *field_idf = NSYMBOL (SUB (field));
3231 if (phase == L_DECLARE) {
3232 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf));
3233 if (entry == NO_BOOK) {
3234 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
3235 (void) add_declaration (&root_idf, "A68_REF", 1, ref);
3236 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field));
3237 }
3238 if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) {
3239 (void) make_name (sel, SEL, "", NUMBER (field));
3240 (void) add_declaration (&root_idf, inline_mode (SUB_MOID (field)), 1, sel);
3241 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
3242 }
3243 inline_unit (sec, out, L_DECLARE);
3244 } else if (phase == L_EXECUTE) {
3245 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
3246 if (entry == NO_BOOK) {
3247 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
3248 get_stack (idf, out, ref, "A68_REF");
3249 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), NULL, NUMBER (field));
3250 }
3251 if (entry == NO_BOOK) {
3252 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
3253 (void) make_name (sel, SEL, "", NUMBER (field));
3254 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[%d]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field)));
3255 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
3256 } else if (field_idf != (char *) (INFO (entry))) {
3257 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry));
3258 (void) make_name (sel, SEL, "", NUMBER (field));
3259 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[%d]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field)));
3260 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
3261 }
3262 inline_unit (sec, out, L_EXECUTE);
3263 } else if (phase == L_YIELD) {
3264 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
3265 if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) {
3266 (void) make_name (sel, SEL, "", NUMBER (entry));
3267 } else {
3268 (void) make_name (sel, SEL, "", NUMBER (field));
3269 }
3270 if (primitive_mode (SUB_MOID (p))) {
3271 undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", sel));
3272 } else if (SUB_MOID (p) == MODE (COMPLEX)) {
3273 undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", sel));
3274 } else if (LONG_MODE (SUB_MOID (p))) {
3275 undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", sel));
3276 } else if (basic_mode (SUB_MOID (p))) {
3277 undent (out, sel);
3278 } else {
3279 ABEND (A68_TRUE, "strange mode in dereference selection (yield)", NO_TEXT);
3280 }
3281 }
3282 }
3283
3284 /**
3285 @brief Code selection.
3286 @param p Starting node.
3287 @param out Object file.
3288 @param phase Phase of code generation.
3289 **/
3290
3291 static void
inline_selection(NODE_T * p,FILE_T out,int phase)3292 inline_selection (NODE_T * p, FILE_T out, int phase)
3293 {
3294 NODE_T *field = SUB (p);
3295 NODE_T *sec = NEXT (field);
3296 NODE_T *idf = locate (sec, IDENTIFIER);
3297 char ref[NAME_SIZE], sel[NAME_SIZE];
3298 char *field_idf = NSYMBOL (SUB (field));
3299 if (phase == L_DECLARE) {
3300 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf));
3301 if (entry == NO_BOOK) {
3302 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
3303 (void) add_declaration (&root_idf, "A68_STRUCT", 0, ref);
3304 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field));
3305 }
3306 if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) {
3307 (void) make_name (sel, SEL, "", NUMBER (field));
3308 (void) add_declaration (&root_idf, inline_mode (MOID (field)), 1, sel);
3309 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
3310 }
3311 inline_unit (sec, out, L_DECLARE);
3312 } else if (phase == L_EXECUTE) {
3313 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
3314 if (entry == NO_BOOK) {
3315 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
3316 get_stack (idf, out, ref, "BYTE_T");
3317 (void) make_name (sel, SEL, "", NUMBER (field));
3318 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (%s[%d]);\n", sel, inline_mode (MOID (field)), ref, OFFSET_OFF (field)));
3319 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
3320 } else if (field_idf != (char *) (INFO (entry))) {
3321 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry));
3322 (void) make_name (sel, SEL, "", NUMBER (field));
3323 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (%s[%d]);\n", sel, inline_mode (MOID (field)), ref, OFFSET_OFF (field)));
3324 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
3325 }
3326 inline_unit (sec, out, L_EXECUTE);
3327 } else if (phase == L_YIELD) {
3328 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
3329 if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) {
3330 (void) make_name (sel, SEL, "", NUMBER (entry));
3331 } else {
3332 (void) make_name (sel, SEL, "", NUMBER (field));
3333 }
3334 if (primitive_mode (MOID (p))) {
3335 undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", sel));
3336 } else {
3337 ABEND (A68_TRUE, "strange mode in selection (yield)", NO_TEXT);
3338 }
3339 }
3340 }
3341
3342 /**
3343 @brief Code selection.
3344 @param p Starting node.
3345 @param out Object file.
3346 @param phase Phase of code generation.
3347 **/
3348
3349 static void
inline_selection_ref_to_ref(NODE_T * p,FILE_T out,int phase)3350 inline_selection_ref_to_ref (NODE_T * p, FILE_T out, int phase)
3351 {
3352 NODE_T *field = SUB (p);
3353 NODE_T *sec = NEXT (field);
3354 NODE_T *idf = locate (sec, IDENTIFIER);
3355 char ref[NAME_SIZE], sel[NAME_SIZE];
3356 char *field_idf = NSYMBOL (SUB (field));
3357 if (phase == L_DECLARE) {
3358 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf));
3359 if (entry == NO_BOOK) {
3360 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
3361 (void) add_declaration (&root_idf, "A68_REF", 1, ref);
3362 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field));
3363 }
3364 if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) {
3365 (void) make_name (sel, SEL, "", NUMBER (field));
3366 (void) add_declaration (&root_idf, "A68_REF", 0, sel);
3367 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
3368 }
3369 inline_unit (sec, out, L_DECLARE);
3370 } else if (phase == L_EXECUTE) {
3371 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf));
3372 if (entry == NO_BOOK) {
3373 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
3374 get_stack (idf, out, ref, "A68_REF");
3375 (void) make_name (sel, SEL, "", NUMBER (field));
3376 sign_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
3377 } else if (field_idf != (char *) (INFO (entry))) {
3378 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry));
3379 (void) make_name (sel, SEL, "", NUMBER (field));
3380 sign_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
3381 }
3382 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = *%s;\n", sel, ref));
3383 indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (&%s) += %d;\n", sel, OFFSET_OFF (field)));
3384 inline_unit (sec, out, L_EXECUTE);
3385 } else if (phase == L_YIELD) {
3386 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
3387 if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) {
3388 (void) make_name (sel, SEL, "", NUMBER (entry));
3389 } else {
3390 (void) make_name (sel, SEL, "", NUMBER (field));
3391 }
3392 if (primitive_mode (SUB_MOID (p))) {
3393 undentf (out, snprintf (line, SNPRINTF_SIZE, "(&%s)", sel));
3394 } else {
3395 ABEND (A68_TRUE, "strange mode in selection (yield)", NO_TEXT);
3396 }
3397 }
3398 }
3399
3400 /**
3401 @brief Code identifier.
3402 @param p Starting node.
3403 @param out Object file.
3404 @param phase Phase of code generation.
3405 **/
3406
3407 static void
inline_ref_identifier(NODE_T * p,FILE_T out,int phase)3408 inline_ref_identifier (NODE_T * p, FILE_T out, int phase)
3409 {
3410 /* No folding - consider identifier */
3411 if (phase == L_DECLARE) {
3412 if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (p)) != NO_BOOK) {
3413 return;
3414 } else {
3415 char idf[NAME_SIZE];
3416 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
3417 (void) add_declaration (&root_idf, "A68_REF", 1, idf);
3418 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p));
3419 }
3420 } else if (phase == L_EXECUTE) {
3421 if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)) != NO_BOOK) {
3422 return;
3423 } else {
3424 char idf[NAME_SIZE];
3425 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
3426 get_stack (p, out, idf, "A68_REF");
3427 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
3428 }
3429 } else if (phase == L_YIELD) {
3430 char idf[NAME_SIZE];
3431 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p));
3432 if (entry != NO_BOOK) {
3433 (void) make_name (idf, NSYMBOL (p), "", NUMBER (entry));
3434 } else {
3435 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
3436 }
3437 undent (out, idf);
3438 }
3439 }
3440
3441 /**
3442 @brief Code identity-relation.
3443 @param p Starting node.
3444 @param out Output file descriptor.
3445 @param phase Phase of code generation.
3446 **/
3447
3448 static void
inline_identity_relation(NODE_T * p,FILE_T out,int phase)3449 inline_identity_relation (NODE_T * p, FILE_T out, int phase)
3450 {
3451 #define GOOD(p) (locate (p, IDENTIFIER) != NO_NODE && IS (MOID (locate ((p), IDENTIFIER)), REF_SYMBOL))
3452 NODE_T *lhs = SUB (p);
3453 NODE_T *op = NEXT (lhs);
3454 NODE_T *rhs = NEXT (op);
3455 if (GOOD (lhs) && GOOD (rhs)) {
3456 if (phase == L_DECLARE) {
3457 NODE_T *lidf = locate (lhs, IDENTIFIER);
3458 NODE_T *ridf = locate (rhs, IDENTIFIER);
3459 inline_ref_identifier (lidf, out, L_DECLARE);
3460 inline_ref_identifier (ridf, out, L_DECLARE);
3461 } else if (phase == L_EXECUTE) {
3462 NODE_T *lidf = locate (lhs, IDENTIFIER);
3463 NODE_T *ridf = locate (rhs, IDENTIFIER);
3464 inline_ref_identifier (lidf, out, L_EXECUTE);
3465 inline_ref_identifier (ridf, out, L_EXECUTE);
3466 } else if (phase == L_YIELD) {
3467 NODE_T *lidf = locate (lhs, IDENTIFIER);
3468 NODE_T *ridf = locate (rhs, IDENTIFIER);
3469 if (IS (op, IS_SYMBOL)) {
3470 undentf (out, snprintf (line, SNPRINTF_SIZE, "ADDRESS ("));
3471 inline_ref_identifier (lidf, out, L_YIELD);
3472 undentf (out, snprintf (line, SNPRINTF_SIZE, ") == ADDRESS ("));
3473 inline_ref_identifier (ridf, out, L_YIELD);
3474 undentf (out, snprintf (line, SNPRINTF_SIZE, ")"));
3475 } else {
3476 undentf (out, snprintf (line, SNPRINTF_SIZE, "ADDRESS ("));
3477 inline_ref_identifier (lidf, out, L_YIELD);
3478 undentf (out, snprintf (line, SNPRINTF_SIZE, ") != ADDRESS ("));
3479 inline_ref_identifier (ridf, out, L_YIELD);
3480 undentf (out, snprintf (line, SNPRINTF_SIZE, ")"));
3481 }
3482 }
3483 } else if (GOOD (lhs) && locate (rhs, NIHIL) != NO_NODE) {
3484 if (phase == L_DECLARE) {
3485 NODE_T *lidf = locate (lhs, IDENTIFIER);
3486 inline_ref_identifier (lidf, out, L_DECLARE);
3487 } else if (phase == L_EXECUTE) {
3488 NODE_T *lidf = locate (lhs, IDENTIFIER);
3489 inline_ref_identifier (lidf, out, L_EXECUTE);
3490 } else if (phase == L_YIELD) {
3491 NODE_T *lidf = locate (lhs, IDENTIFIER);
3492 if (IS (op, IS_SYMBOL)) {
3493 indentf (out, snprintf (line, SNPRINTF_SIZE, "IS_NIL (*"));
3494 inline_ref_identifier (lidf, out, L_YIELD);
3495 undentf (out, snprintf (line, SNPRINTF_SIZE, ")"));
3496 } else {
3497 indentf (out, snprintf (line, SNPRINTF_SIZE, "!IS_NIL (*"));
3498 inline_ref_identifier (lidf, out, L_YIELD);
3499 undentf (out, snprintf (line, SNPRINTF_SIZE, ")"));
3500 }
3501 }
3502 }
3503 #undef GOOD
3504 }
3505
3506 /**
3507 @brief Code unit.
3508 @param p Starting node.
3509 @param out Object file.
3510 @param phase Phase of code generation.
3511 **/
3512
3513 static void
inline_unit(NODE_T * p,FILE_T out,int phase)3514 inline_unit (NODE_T * p, FILE_T out, int phase)
3515 {
3516 if (p == NO_NODE) {
3517 return;
3518 } else if (constant_unit (p) && locate (p, DENOTATION) == NO_NODE) {
3519 constant_folder (p, out, phase);
3520 } else if (IS (p, UNIT)) {
3521 inline_unit (SUB (p), out, phase);
3522 } else if (IS (p, TERTIARY)) {
3523 inline_unit (SUB (p), out, phase);
3524 } else if (IS (p, SECONDARY)) {
3525 inline_unit (SUB (p), out, phase);
3526 } else if (IS (p, PRIMARY)) {
3527 inline_unit (SUB (p), out, phase);
3528 } else if (IS (p, ENCLOSED_CLAUSE)) {
3529 inline_unit (SUB (p), out, phase);
3530 } else if (IS (p, CLOSED_CLAUSE)) {
3531 inline_closed (p, out, phase);
3532 } else if (IS (p, COLLATERAL_CLAUSE)) {
3533 inline_collateral (p, out, phase);
3534 } else if (IS (p, CONDITIONAL_CLAUSE)) {
3535 inline_conditional (p, out, phase);
3536 } else if (IS (p, WIDENING)) {
3537 inline_widening (p, out, phase);
3538 } else if (IS (p, IDENTIFIER)) {
3539 inline_identifier (p, out, phase);
3540 } else if (IS (p, DEREFERENCING) && locate (SUB (p), IDENTIFIER) != NO_NODE) {
3541 inline_dereference_identifier (p, out, phase);
3542 } else if (IS (p, SLICE)) {
3543 NODE_T *prim = SUB (p);
3544 MOID_T *mode = MOID (p);
3545 MOID_T *row_mode = DEFLEX (MOID (prim));
3546 if (mode == SUB (row_mode)) {
3547 inline_slice (p, out, phase);
3548 } else if (IS (mode, REF_SYMBOL) && IS (row_mode, REF_SYMBOL) && SUB (mode) == SUB_SUB (row_mode)) {
3549 inline_slice_ref_to_ref (p, out, phase);
3550 } else {
3551 ABEND (A68_TRUE, "strange mode for slice", NO_TEXT);
3552 }
3553 } else if (IS (p, DEREFERENCING) && locate (SUB (p), SLICE) != NO_NODE) {
3554 inline_dereference_slice (SUB (p), out, phase);
3555 } else if (IS (p, DEREFERENCING) && locate (SUB (p), SELECTION) != NO_NODE) {
3556 inline_dereference_selection (SUB (p), out, phase);
3557 } else if (IS (p, SELECTION)) {
3558 NODE_T *sec = NEXT_SUB (p);
3559 MOID_T *mode = MOID (p);
3560 MOID_T *struct_mode = MOID (sec);
3561 if (IS (struct_mode, REF_SYMBOL) && IS (mode, REF_SYMBOL)) {
3562 inline_selection_ref_to_ref (p, out, phase);
3563 } else if (IS (struct_mode, STRUCT_SYMBOL) && primitive_mode (mode)) {
3564 inline_selection (p, out, phase);
3565 } else {
3566 ABEND (A68_TRUE, "strange mode for selection", NO_TEXT);
3567 }
3568 } else if (IS (p, DENOTATION)) {
3569 inline_denotation (p, out, phase);
3570 } else if (IS (p, MONADIC_FORMULA)) {
3571 inline_monadic_formula (p, out, phase);
3572 } else if (IS (p, FORMULA)) {
3573 inline_formula (p, out, phase);
3574 } else if (IS (p, CALL)) {
3575 inline_call (p, out, phase);
3576 } else if (IS (p, CAST)) {
3577 inline_unit (NEXT_SUB (p), out, phase);
3578 } else if (IS (p, IDENTITY_RELATION)) {
3579 inline_identity_relation (p, out, phase);
3580 }
3581 }
3582
3583 /*********************************/
3584 /* COMPILATION OF COMPLETE UNITS */
3585 /*********************************/
3586
3587 /**
3588 @brief Compile code clause.
3589 @param out Output file descriptor.
3590 @param p Starting node.
3591 @return Function name or NO_NODE.
3592 **/
3593
3594 static void
embed_code_clause(NODE_T * p,FILE_T out)3595 embed_code_clause (NODE_T * p, FILE_T out)
3596 {
3597 for (; p != NO_NODE; FORWARD (p)) {
3598 if (IS (p, ROW_CHAR_DENOTATION)) {
3599 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s\n", NSYMBOL (p)));
3600 }
3601 embed_code_clause (SUB (p), out);
3602 }
3603 }
3604
3605 /**
3606 @brief Compile push.
3607 @param p Starting node.
3608 @param out Output file descriptor.
3609 **/
3610
3611 static void
compile_push(NODE_T * p,FILE_T out)3612 compile_push (NODE_T * p, FILE_T out)
3613 {
3614 if (primitive_mode (MOID (p))) {
3615 indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, "));
3616 inline_unit (p, out, L_YIELD);
3617 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
3618 } else if (basic_mode (MOID (p))) {
3619 indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE ((void *) STACK_TOP, (void *) "));
3620 inline_unit (p, out, L_YIELD);
3621 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
3622 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer += %d;\n", SIZE (MOID (p))));
3623 } else {
3624 ABEND (A68_TRUE, "cannot push", moid_to_string (MOID (p), 80, NO_NODE));
3625 }
3626 }
3627
3628 /**
3629 @brief Compile assign (C source to C destination).
3630 @param p Starting node.
3631 @param out Output file descriptor.
3632 @param dst String denoting destination.
3633 **/
3634
3635 static void
compile_assign(NODE_T * p,FILE_T out,char * dst)3636 compile_assign (NODE_T * p, FILE_T out, char *dst)
3637 {
3638 if (primitive_mode (MOID (p))) {
3639 indentf (out, snprintf (line, SNPRINTF_SIZE, "_S_ (%s) = INIT_MASK;\n", dst));
3640 indentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s) = ", dst));
3641 inline_unit (p, out, L_YIELD);
3642 undent (out, ";\n");
3643 } else if (LONG_MODE (MOID (p))) {
3644 indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE_MP ((void *) %s, (void *) ", dst));
3645 inline_unit (p, out, L_YIELD);
3646 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS));
3647 } else if (basic_mode (MOID (p))) {
3648 indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", dst));
3649 inline_unit (p, out, L_YIELD);
3650 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
3651 } else {
3652 ABEND (A68_TRUE, "cannot assign", moid_to_string (MOID (p), 80, NO_NODE));
3653 }
3654 }
3655
3656 /**
3657 @brief Compile denotation.
3658 @param p Starting node.
3659 @param out Output file descriptor.
3660 @param compose_fun Whether to compose a function.
3661 @return Function name.
3662 **/
3663
3664 static char *
compile_denotation(NODE_T * p,FILE_T out,int compose_fun)3665 compile_denotation (NODE_T * p, FILE_T out, int compose_fun)
3666 {
3667 if (denotation_mode (MOID (p))) {
3668 static char fn[NAME_SIZE];
3669 comment_source (p, out);
3670 (void) make_name (fn, "_denotation", "", NUMBER (p));
3671 if (compose_fun == A68_MAKE_FUNCTION) {
3672 write_fun_prelude (p, out, fn);
3673 }
3674 root_idf = NO_DEC;
3675 inline_unit (p, out, L_DECLARE);
3676 print_declarations (out, root_idf);
3677 inline_unit (p, out, L_EXECUTE);
3678 if (primitive_mode (MOID (p))) {
3679 indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, "));
3680 inline_unit (p, out, L_YIELD);
3681 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
3682 } else {
3683 indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH (p, "));
3684 inline_unit (p, out, L_YIELD);
3685 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
3686 }
3687 (void) make_name (fn, "_denotation", "", NUMBER (p));
3688 if (compose_fun == A68_MAKE_FUNCTION) {
3689 write_fun_postlude (p, out, fn);
3690 }
3691 return (fn);
3692 } else {
3693 return (NO_TEXT);
3694 }
3695 }
3696
3697 /**
3698 @brief Compile cast.
3699 @param p Starting node.
3700 @param out Output file descriptor.
3701 @param compose_fun Whether to compose a function.
3702 @return Function name.
3703 **/
3704
3705 static char *
compile_cast(NODE_T * p,FILE_T out,int compose_fun)3706 compile_cast (NODE_T * p, FILE_T out, int compose_fun)
3707 {
3708 if (basic_unit (p)) {
3709 static char fn[NAME_SIZE];
3710 comment_source (p, out);
3711 (void) make_name (fn, "_cast", "", NUMBER (p));
3712 if (compose_fun == A68_MAKE_FUNCTION) {
3713 write_fun_prelude (p, out, fn);
3714 }
3715 root_idf = NO_DEC;
3716 inline_unit (NEXT_SUB (p), out, L_DECLARE);
3717 print_declarations (out, root_idf);
3718 inline_unit (NEXT_SUB (p), out, L_EXECUTE);
3719 compile_push (NEXT_SUB (p), out);
3720 if (compose_fun == A68_MAKE_FUNCTION) {
3721 (void) make_name (fn, "_cast", "", NUMBER (p));
3722 write_fun_postlude (p, out, fn);
3723 }
3724 return (fn);
3725 } else {
3726 return (NO_TEXT);
3727 }
3728 }
3729
3730 /**
3731 @brief Compile identifier.
3732 @param p Starting node.
3733 @param out Output file descriptor.
3734 @param compose_fun Whether to compose a function.
3735 @return Function name.
3736 **/
3737
3738 static char *
compile_identifier(NODE_T * p,FILE_T out,int compose_fun)3739 compile_identifier (NODE_T * p, FILE_T out, int compose_fun)
3740 {
3741 if (basic_mode (MOID (p)) && basic_unit (p)) {
3742 static char fn[NAME_SIZE];
3743 comment_source (p, out);
3744 (void) make_name (fn, "_identifier", "", NUMBER (p));
3745 if (compose_fun == A68_MAKE_FUNCTION) {
3746 write_fun_prelude (p, out, fn);
3747 }
3748 root_idf = NO_DEC;
3749 inline_unit (p, out, L_DECLARE);
3750 print_declarations (out, root_idf);
3751 inline_unit (p, out, L_EXECUTE);
3752 compile_push (p, out);
3753 (void) make_name (fn, "_identifier", "", NUMBER (p));
3754 if (compose_fun == A68_MAKE_FUNCTION) {
3755 write_fun_postlude (p, out, fn);
3756 }
3757 return (fn);
3758 } else {
3759 return (NO_TEXT);
3760 }
3761 }
3762
3763 /**
3764 @brief Compile dereference identifier.
3765 @param p Starting node.
3766 @param out Output file descriptor.
3767 @param compose_fun Whether to compose a function.
3768 @return Function name.
3769 **/
3770
3771 static char *
compile_dereference_identifier(NODE_T * p,FILE_T out,int compose_fun)3772 compile_dereference_identifier (NODE_T * p, FILE_T out, int compose_fun)
3773 {
3774 if (basic_mode (MOID (p)) && basic_unit (p)) {
3775 static char fn[NAME_SIZE];
3776 comment_source (p, out);
3777 (void) make_name (fn, "_deref_identifier", "", NUMBER (p));
3778 if (compose_fun == A68_MAKE_FUNCTION) {
3779 write_fun_prelude (p, out, fn);
3780 }
3781 root_idf = NO_DEC;
3782 inline_unit (p, out, L_DECLARE);
3783 print_declarations (out, root_idf);
3784 inline_unit (p, out, L_EXECUTE);
3785 compile_push (p, out);
3786 (void) make_name (fn, "_deref_identifier", "", NUMBER (p));
3787 if (compose_fun == A68_MAKE_FUNCTION) {
3788 write_fun_postlude (p, out, fn);
3789 }
3790 return (fn);
3791 } else {
3792 return (NO_TEXT);
3793 }
3794 }
3795
3796 /**
3797 @brief Compile slice.
3798 @param p Starting node.
3799 @param out Output file descriptor.
3800 @param compose_fun Whether to compose a function.
3801 @return Function name.
3802 **/
3803
3804 static char *
compile_slice(NODE_T * p,FILE_T out,int compose_fun)3805 compile_slice (NODE_T * p, FILE_T out, int compose_fun)
3806 {
3807 if (basic_mode (MOID (p)) && basic_unit (p)) {
3808 static char fn[NAME_SIZE];
3809 comment_source (p, out);
3810 (void) make_name (fn, "_slice", "", NUMBER (p));
3811 if (compose_fun == A68_MAKE_FUNCTION) {
3812 write_fun_prelude (p, out, fn);
3813 }
3814 root_idf = NO_DEC;
3815 inline_unit (p, out, L_DECLARE);
3816 print_declarations (out, root_idf);
3817 inline_unit (p, out, L_EXECUTE);
3818 compile_push (p, out);
3819 if (compose_fun == A68_MAKE_FUNCTION) {
3820 (void) make_name (fn, "_slice", "", NUMBER (p));
3821 write_fun_postlude (p, out, fn);
3822 }
3823 return (fn);
3824 } else {
3825 return (NO_TEXT);
3826 }
3827 }
3828
3829 /**
3830 @brief Compile slice.
3831 @param p Starting node.
3832 @param out Output file descriptor.
3833 @param compose_fun Whether to compose a function.
3834 @return Function name.
3835 **/
3836
3837 static char *
compile_dereference_slice(NODE_T * p,FILE_T out,int compose_fun)3838 compile_dereference_slice (NODE_T * p, FILE_T out, int compose_fun)
3839 {
3840 if (basic_mode (MOID (p)) && basic_unit (p)) {
3841 static char fn[NAME_SIZE];
3842 comment_source (p, out);
3843 (void) make_name (fn, "_deref_slice", "", NUMBER (p));
3844 if (compose_fun == A68_MAKE_FUNCTION) {
3845 write_fun_prelude (p, out, fn);
3846 }
3847 root_idf = NO_DEC;
3848 inline_unit (p, out, L_DECLARE);
3849 print_declarations (out, root_idf);
3850 inline_unit (p, out, L_EXECUTE);
3851 compile_push (p, out);
3852 if (compose_fun == A68_MAKE_FUNCTION) {
3853 (void) make_name (fn, "_deref_slice", "", NUMBER (p));
3854 write_fun_postlude (p, out, fn);
3855 }
3856 return (fn);
3857 } else {
3858 return (NO_TEXT);
3859 }
3860 }
3861
3862 /**
3863 @brief Compile selection.
3864 @param p Starting node.
3865 @param out Output file descriptor.
3866 @param compose_fun Whether to compose a function.
3867 @return Function name.
3868 **/
3869
3870 static char *
compile_selection(NODE_T * p,FILE_T out,int compose_fun)3871 compile_selection (NODE_T * p, FILE_T out, int compose_fun)
3872 {
3873 if (basic_mode (MOID (p)) && basic_unit (p)) {
3874 static char fn[NAME_SIZE];
3875 comment_source (p, out);
3876 (void) make_name (fn, "_selection", "", NUMBER (p));
3877 if (compose_fun == A68_MAKE_FUNCTION) {
3878 write_fun_prelude (p, out, fn);
3879 }
3880 root_idf = NO_DEC;
3881 inline_unit (p, out, L_DECLARE);
3882 print_declarations (out, root_idf);
3883 inline_unit (p, out, L_EXECUTE);
3884 compile_push (p, out);
3885 if (compose_fun == A68_MAKE_FUNCTION) {
3886 (void) make_name (fn, "_selection", "", NUMBER (p));
3887 write_fun_postlude (p, out, fn);
3888 }
3889 return (fn);
3890 } else {
3891 return (NO_TEXT);
3892 }
3893 }
3894
3895 /**
3896 @brief Compile selection.
3897 @param p Starting node.
3898 @param out Output file descriptor.
3899 @param compose_fun Whether to compose a function.
3900 @return Function name.
3901 **/
3902
3903 static char *
compile_dereference_selection(NODE_T * p,FILE_T out,int compose_fun)3904 compile_dereference_selection (NODE_T * p, FILE_T out, int compose_fun)
3905 {
3906 if (basic_mode (MOID (p)) && basic_unit (p)) {
3907 static char fn[NAME_SIZE];
3908 comment_source (p, out);
3909 (void) make_name (fn, "_deref_selection", "", NUMBER (p));
3910 if (compose_fun == A68_MAKE_FUNCTION) {
3911 write_fun_prelude (p, out, fn);
3912 }
3913 root_idf = NO_DEC;
3914 inline_unit (p, out, L_DECLARE);
3915 print_declarations (out, root_idf);
3916 inline_unit (p, out, L_EXECUTE);
3917 compile_push (p, out);
3918 if (compose_fun == A68_MAKE_FUNCTION) {
3919 (void) make_name (fn, "_deref_selection", "", NUMBER (p));
3920 write_fun_postlude (p, out, fn);
3921 }
3922 return (fn);
3923 } else {
3924 return (NO_TEXT);
3925 }
3926 }
3927
3928 /**
3929 @brief Compile formula.
3930 @param p Starting node.
3931 @param out Output file descriptor.
3932 @param compose_fun Whether to compose a function.
3933 @return Function name.
3934 **/
3935
3936 static char *
compile_formula(NODE_T * p,FILE_T out,int compose_fun)3937 compile_formula (NODE_T * p, FILE_T out, int compose_fun)
3938 {
3939 if (basic_unit (p)) {
3940 static char fn[NAME_SIZE];
3941 comment_source (p, out);
3942 (void) make_name (fn, "_formula", "", NUMBER (p));
3943 if (compose_fun == A68_MAKE_FUNCTION) {
3944 write_fun_prelude (p, out, fn);
3945 }
3946 root_idf = NO_DEC;
3947 inline_unit (p, out, L_DECLARE);
3948 print_declarations (out, root_idf);
3949 inline_unit (p, out, L_EXECUTE);
3950 compile_push (p, out);
3951 if (compose_fun == A68_MAKE_FUNCTION) {
3952 (void) make_name (fn, "_formula", "", NUMBER (p));
3953 write_fun_postlude (p, out, fn);
3954 }
3955 return (fn);
3956 } else {
3957 return (NO_TEXT);
3958 }
3959 }
3960
3961 /**
3962 @brief Compile voiding formula.
3963 @param p Starting node.
3964 @param out Output file descriptor.
3965 @param compose_fun Whether to compose a function.
3966 @return Function name.
3967 **/
3968
3969 static char *
compile_voiding_formula(NODE_T * p,FILE_T out,int compose_fun)3970 compile_voiding_formula (NODE_T * p, FILE_T out, int compose_fun)
3971 {
3972 if (basic_unit (p)) {
3973 static char fn[NAME_SIZE];
3974 char pop[NAME_SIZE];
3975 (void) make_name (pop, PUP, "", NUMBER (p));
3976 comment_source (p, out);
3977 (void) make_name (fn, "_void_formula", "", NUMBER (p));
3978 if (compose_fun == A68_MAKE_FUNCTION) {
3979 write_fun_prelude (p, out, fn);
3980 }
3981 root_idf = NO_DEC;
3982 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
3983 inline_unit (p, out, L_DECLARE);
3984 print_declarations (out, root_idf);
3985 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
3986 inline_unit (p, out, L_EXECUTE);
3987 indent (out, "(void) (");
3988 inline_unit (p, out, L_YIELD);
3989 undent (out, ");\n");
3990 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
3991 if (compose_fun == A68_MAKE_FUNCTION) {
3992 (void) make_name (fn, "_void_formula", "", NUMBER (p));
3993 write_fun_postlude (p, out, fn);
3994 }
3995 return (fn);
3996 } else {
3997 return (NO_TEXT);
3998 }
3999 }
4000
4001 /**
4002 @brief Compile uniting.
4003 @param p Starting node.
4004 @param out Output file descriptor.
4005 @param compose_fun Whether to compose a function.
4006 @return Function name.
4007 **/
4008
4009 static char *
compile_uniting(NODE_T * p,FILE_T out,int compose_fun)4010 compile_uniting (NODE_T * p, FILE_T out, int compose_fun)
4011 {
4012 MOID_T *u = MOID (p), *v = MOID (SUB (p));
4013 NODE_T *q = SUB (p);
4014 if (basic_unit (q) && ATTRIBUTE (v) != UNION_SYMBOL && primitive_mode (v)) {
4015 static char fn[NAME_SIZE];
4016 char pop0[NAME_SIZE];
4017 (void) make_name (pop0, PUP, "0", NUMBER (p));
4018 comment_source (p, out);
4019 (void) make_name (fn, "_unite", "", NUMBER (p));
4020 if (compose_fun == A68_MAKE_FUNCTION) {
4021 write_fun_prelude (p, out, fn);
4022 }
4023 root_idf = NO_DEC;
4024 (void) add_declaration (&root_idf, "ADDR_T", 0, pop0);
4025 inline_unit (q, out, L_DECLARE);
4026 print_declarations (out, root_idf);
4027 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop0));
4028 indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_UNION (_N_ (%d), %s);\n", NUMBER (p), internal_mode (v)));
4029 inline_unit (q, out, L_EXECUTE);
4030 compile_push (q, out);
4031 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s + %d;\n", pop0, SIZE (u)));
4032 if (compose_fun == A68_MAKE_FUNCTION) {
4033 write_fun_postlude (p, out, fn);
4034 }
4035 return (fn);
4036 } else {
4037 return (NO_TEXT);
4038 }
4039 }
4040
4041 /**
4042 @brief Compile inline arguments.
4043 @param p Starting node.
4044 @param out Output file descriptor.
4045 @param phase Compilation phase.
4046 @param size Position in frame stack.
4047 **/
4048
4049 static void
inline_arguments(NODE_T * p,FILE_T out,int phase,int * size)4050 inline_arguments (NODE_T * p, FILE_T out, int phase, int *size)
4051 {
4052 if (p == NO_NODE) {
4053 return;
4054 } else if (IS (p, UNIT) && phase == L_PUSH) {
4055 indentf (out, snprintf (line, SNPRINTF_SIZE, "EXECUTE_UNIT_TRACE (_N_ (%d));\n", NUMBER (p)));
4056 inline_arguments (NEXT (p), out, L_PUSH, size);
4057 } else if (IS (p, UNIT)) {
4058 char arg[NAME_SIZE];
4059 (void) make_name (arg, ARG, "", NUMBER (p));
4060 if (phase == L_DECLARE) {
4061 (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, arg);
4062 inline_unit (p, out, L_DECLARE);
4063 } else if (phase == L_INITIALISE) {
4064 inline_unit (p, out, L_EXECUTE);
4065 } else if (phase == L_EXECUTE) {
4066 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) FRAME_OBJECT (%d);\n", arg, inline_mode (MOID (p)), *size));
4067 (*size) += SIZE (MOID (p));
4068 } else if (phase == L_YIELD && primitive_mode (MOID (p))) {
4069 indentf (out, snprintf (line, SNPRINTF_SIZE, "_S_ (%s) = INIT_MASK;\n", arg));
4070 indentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s) = ", arg));
4071 inline_unit (p, out, L_YIELD);
4072 undent (out, ";\n");
4073 } else if (phase == L_YIELD && basic_mode (MOID (p))) {
4074 indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", arg));
4075 inline_unit (p, out, L_YIELD);
4076 undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
4077 }
4078 } else {
4079 inline_arguments (SUB (p), out, phase, size);
4080 inline_arguments (NEXT (p), out, phase, size);
4081 }
4082 }
4083
4084 /**
4085 @brief Compile deproceduring.
4086 @param out Output file descriptor.
4087 @param p Starting node.
4088 @param compose_fun Whether to compose a function.
4089 @return Function name or NO_NODE.
4090 **/
4091
4092 static char *
compile_deproceduring(NODE_T * p,FILE_T out,int compose_fun)4093 compile_deproceduring (NODE_T * p, FILE_T out, int compose_fun)
4094 {
4095 NODE_T *idf = locate (SUB (p), IDENTIFIER);
4096 if (idf == NO_NODE) {
4097 return (NO_TEXT);
4098 } else if (!(SUB_MOID (idf) == MODE (VOID) || basic_mode (SUB_MOID (idf)))) {
4099 return (NO_TEXT);
4100 } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
4101 return (NO_TEXT);
4102 } else {
4103 static char fn[NAME_SIZE];
4104 char fun[NAME_SIZE];
4105 (void) make_name (fun, FUN, "", NUMBER (idf));
4106 comment_source (p, out);
4107 (void) make_name (fn, "_deproc", "", NUMBER (p));
4108 if (compose_fun == A68_MAKE_FUNCTION) {
4109 write_fun_prelude (p, out, fn);
4110 }
4111 /* Declare */
4112 root_idf = NO_DEC;
4113 (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun);
4114 (void) add_declaration (&root_idf, "NODE_T", 1, "body");
4115 print_declarations (out, root_idf);
4116 /* Initialise */
4117 if (compose_fun != A68_MAKE_NOTHING) {
4118 }
4119 get_stack (idf, out, fun, "A68_PROCEDURE");
4120 indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun));
4121 indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun));
4122 indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
4123 /* Execute procedure */
4124 indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT (body));\n");
4125 indent (out, "if (frame_pointer == finish_frame_pointer) {\n");
4126 indentation++;
4127 indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
4128 indentation--;
4129 indent (out, "}\n");
4130 indent (out, "CLOSE_FRAME;\n");
4131 if (GC_MODE (SUB_MOID (idf))) {
4132 }
4133 if (compose_fun == A68_MAKE_FUNCTION) {
4134 (void) make_name (fn, "_deproc", "", NUMBER (p));
4135 write_fun_postlude (p, out, fn);
4136 }
4137 return (fn);
4138 }
4139 }
4140
4141 /**
4142 @brief Compile deproceduring.
4143 @param out Output file descriptor.
4144 @param p Starting node.
4145 @param compose_fun Whether to compose a function.
4146 @return Function name.
4147 **/
4148
4149 static char *
compile_voiding_deproceduring(NODE_T * p,FILE_T out,int compose_fun)4150 compile_voiding_deproceduring (NODE_T * p, FILE_T out, int compose_fun)
4151 {
4152 NODE_T *idf = locate (SUB_SUB (p), IDENTIFIER);
4153 if (idf == NO_NODE) {
4154 return (NO_TEXT);
4155 } else if (!(SUB_MOID (idf) == MODE (VOID) || basic_mode (SUB_MOID (idf)))) {
4156 return (NO_TEXT);
4157 } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
4158 return (NO_TEXT);
4159 } else {
4160 static char fn[NAME_SIZE];
4161 char fun[NAME_SIZE], pop[NAME_SIZE];
4162 (void) make_name (fun, FUN, "", NUMBER (idf));
4163 (void) make_name (pop, PUP, "", NUMBER (p));
4164 comment_source (p, out);
4165 (void) make_name (fn, "_void_deproc", "", NUMBER (p));
4166 if (compose_fun == A68_MAKE_FUNCTION) {
4167 write_fun_prelude (p, out, fn);
4168 }
4169 /* Declare */
4170 root_idf = NO_DEC;
4171 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
4172 (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun);
4173 (void) add_declaration (&root_idf, "NODE_T", 1, "body");
4174 print_declarations (out, root_idf);
4175 /* Initialise */
4176 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
4177 if (compose_fun != A68_MAKE_NOTHING) {
4178 }
4179 get_stack (idf, out, fun, "A68_PROCEDURE");
4180 indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun));
4181 indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun));
4182 indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
4183 /* Execute procedure */
4184 indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT (body));\n");
4185 indent (out, "if (frame_pointer == finish_frame_pointer) {\n");
4186 indentation++;
4187 indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
4188 indentation--;
4189 indent (out, "}\n");
4190 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
4191 indent (out, "CLOSE_FRAME;\n");
4192 if (compose_fun == A68_MAKE_FUNCTION) {
4193 (void) make_name (fn, "_void_deproc", "", NUMBER (p));
4194 write_fun_postlude (p, out, fn);
4195 }
4196 return (fn);
4197 }
4198 }
4199
4200 /**
4201 @brief Compile call.
4202 @param p Starting node.
4203 @param out Output file descriptor.
4204 @param compose_fun Whether to compose a function.
4205 @return Function name.
4206 **/
4207
4208 static char *
compile_call(NODE_T * p,FILE_T out,int compose_fun)4209 compile_call (NODE_T * p, FILE_T out, int compose_fun)
4210 {
4211 NODE_T *proc = SUB (p);
4212 NODE_T *args = NEXT (proc);
4213 NODE_T *idf = locate (proc, IDENTIFIER);
4214 if (idf == NO_NODE) {
4215 return (NO_TEXT);
4216 } else if (!(SUB_MOID (proc) == MODE (VOID) || basic_mode (SUB_MOID (proc)))) {
4217 return (NO_TEXT);
4218 } else if (DIM (MOID (proc)) == 0) {
4219 return (NO_TEXT);
4220 } else if (A68G_STANDENV_PROC (TAX (idf))) {
4221 if (basic_call (p)) {
4222 static char fn[NAME_SIZE];
4223 char fun[NAME_SIZE];
4224 (void) make_name (fun, FUN, "", NUMBER (proc));
4225 comment_source (p, out);
4226 (void) make_name (fn, "_call", "", NUMBER (p));
4227 if (compose_fun == A68_MAKE_FUNCTION) {
4228 write_fun_prelude (p, out, fn);
4229 }
4230 root_idf = NO_DEC;
4231 inline_unit (p, out, L_DECLARE);
4232 print_declarations (out, root_idf);
4233 inline_unit (p, out, L_EXECUTE);
4234 compile_push (p, out);
4235 if (compose_fun == A68_MAKE_FUNCTION) {
4236 (void) make_name (fn, "_call", "", NUMBER (p));
4237 write_fun_postlude (p, out, fn);
4238 }
4239 return (fn);
4240 } else {
4241 return (NO_TEXT);
4242 }
4243 } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
4244 return (NO_TEXT);
4245 } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) {
4246 return (NO_TEXT);
4247 } else if (!basic_argument (args)) {
4248 return (NO_TEXT);
4249 } else {
4250 static char fn[NAME_SIZE];
4251 char fun[NAME_SIZE], pop[NAME_SIZE];
4252 int size;
4253 /* Declare */
4254 (void) make_name (fun, FUN, "", NUMBER (proc));
4255 (void) make_name (pop, PUP, "", NUMBER (p));
4256 comment_source (p, out);
4257 (void) make_name (fn, "_call", "", NUMBER (p));
4258 if (compose_fun == A68_MAKE_FUNCTION) {
4259 write_fun_prelude (p, out, fn);
4260 }
4261 /* Compute arguments */
4262 size = 0;
4263 root_idf = NO_DEC;
4264 inline_arguments (args, out, L_DECLARE, &size);
4265 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
4266 (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun);
4267 (void) add_declaration (&root_idf, "NODE_T", 1, "body");
4268 print_declarations (out, root_idf);
4269 /* Initialise */
4270 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
4271 if (compose_fun != A68_MAKE_NOTHING) {
4272 }
4273 inline_arguments (args, out, L_INITIALISE, &size);
4274 get_stack (idf, out, fun, "A68_PROCEDURE");
4275 indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun));
4276 indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun));
4277 indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
4278 size = 0;
4279 inline_arguments (args, out, L_EXECUTE, &size);
4280 size = 0;
4281 inline_arguments (args, out, L_YIELD, &size);
4282 /* Execute procedure */
4283 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
4284 indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n");
4285 indent (out, "if (frame_pointer == finish_frame_pointer) {\n");
4286 indentation++;
4287 indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
4288 indentation--;
4289 indent (out, "}\n");
4290 indent (out, "CLOSE_FRAME;\n");
4291 if (GC_MODE (SUB_MOID (proc))) {
4292 }
4293 if (compose_fun == A68_MAKE_FUNCTION) {
4294 (void) make_name (fn, "_call", "", NUMBER (p));
4295 write_fun_postlude (p, out, fn);
4296 }
4297 return (fn);
4298 }
4299 }
4300
4301 /**
4302 @brief Compile call.
4303 @param out Output file descriptor.
4304 @param p Starting node.
4305 @param compose_fun Whether to compose a function.
4306 @return Function name.
4307 **/
4308
4309 static char *
compile_voiding_call(NODE_T * p,FILE_T out,int compose_fun)4310 compile_voiding_call (NODE_T * p, FILE_T out, int compose_fun)
4311 {
4312 NODE_T *proc = SUB (locate (p, CALL));
4313 NODE_T *args = NEXT (proc);
4314 NODE_T *idf = locate (proc, IDENTIFIER);
4315 if (idf == NO_NODE) {
4316 return (NO_TEXT);
4317 } else if (!(SUB_MOID (proc) == MODE (VOID) || basic_mode (SUB_MOID (proc)))) {
4318 return (NO_TEXT);
4319 } else if (DIM (MOID (proc)) == 0) {
4320 return (NO_TEXT);
4321 } else if (A68G_STANDENV_PROC (TAX (idf))) {
4322 return (NO_TEXT);
4323 } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
4324 return (NO_TEXT);
4325 } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) {
4326 return (NO_TEXT);
4327 } else if (!basic_argument (args)) {
4328 return (NO_TEXT);
4329 } else {
4330 static char fn[NAME_SIZE];
4331 char fun[NAME_SIZE], pop[NAME_SIZE];
4332 int size;
4333 /* Declare */
4334 (void) make_name (fun, FUN, "", NUMBER (proc));
4335 (void) make_name (pop, PUP, "", NUMBER (p));
4336 comment_source (p, out);
4337 (void) make_name (fn, "_void_call", "", NUMBER (p));
4338 if (compose_fun == A68_MAKE_FUNCTION) {
4339 write_fun_prelude (p, out, fn);
4340 }
4341 /* Compute arguments */
4342 size = 0;
4343 root_idf = NO_DEC;
4344 inline_arguments (args, out, L_DECLARE, &size);
4345 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
4346 (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun);
4347 (void) add_declaration (&root_idf, "NODE_T", 1, "body");
4348 print_declarations (out, root_idf);
4349 /* Initialise */
4350 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
4351 if (compose_fun != A68_MAKE_NOTHING) {
4352 }
4353 inline_arguments (args, out, L_INITIALISE, &size);
4354 get_stack (idf, out, fun, "A68_PROCEDURE");
4355 indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun));
4356 indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun));
4357 indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
4358 size = 0;
4359 inline_arguments (args, out, L_EXECUTE, &size);
4360 size = 0;
4361 inline_arguments (args, out, L_YIELD, &size);
4362 /* Execute procedure */
4363 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
4364 indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n");
4365 indent (out, "if (frame_pointer == finish_frame_pointer) {\n");
4366 indentation++;
4367 indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
4368 indentation--;
4369 indent (out, "}\n");
4370 indent (out, "CLOSE_FRAME;\n");
4371 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
4372 if (compose_fun == A68_MAKE_FUNCTION) {
4373 (void) make_name (fn, "_void_call", "", NUMBER (p));
4374 write_fun_postlude (p, out, fn);
4375 }
4376 return (fn);
4377 }
4378 }
4379
4380 /**
4381 @brief Compile voiding assignation.
4382 @param p Starting node.
4383 @param out Output file descriptor.
4384 @param compose_fun Whether to compose a function.
4385 @return Function name.
4386 **/
4387
4388 static char *
compile_voiding_assignation_selection(NODE_T * p,FILE_T out,int compose_fun)4389 compile_voiding_assignation_selection (NODE_T * p, FILE_T out, int compose_fun)
4390 {
4391 NODE_T *dst = SUB (locate (p, ASSIGNATION));
4392 NODE_T *src = NEXT_NEXT (dst);
4393 if (BASIC (dst, SELECTION) && basic_unit (src) && basic_mode_non_row (MOID (dst))) {
4394 NODE_T *field = SUB (locate (dst, SELECTION));
4395 NODE_T *sec = NEXT (field);
4396 NODE_T *idf = locate (sec, IDENTIFIER);
4397 char sel[NAME_SIZE], ref[NAME_SIZE], pop[NAME_SIZE];
4398 char *field_idf = NSYMBOL (SUB (field));
4399 static char fn[NAME_SIZE];
4400 comment_source (p, out);
4401 (void) make_name (pop, PUP, "", NUMBER (p));
4402 (void) make_name (fn, "_void_assign", "", NUMBER (p));
4403 if (compose_fun == A68_MAKE_FUNCTION) {
4404 write_fun_prelude (p, out, fn);
4405 }
4406 /* Declare */
4407 root_idf = NO_DEC;
4408 if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)) == NO_BOOK) {
4409 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
4410 (void) make_name (sel, SEL, "", NUMBER (field));
4411 indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF * %s; /* %s */\n", ref, NSYMBOL (idf)));
4412 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s * %s;\n", inline_mode (SUB_MOID (field)), sel));
4413 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
4414 } else {
4415 int n = NUMBER (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)));
4416 (void) make_name (ref, NSYMBOL (idf), "", n);
4417 (void) make_name (sel, SEL, "", n);
4418 }
4419 inline_unit (src, out, L_DECLARE);
4420 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
4421 print_declarations (out, root_idf);
4422 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
4423 /* Initialise */
4424 if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)) == NO_BOOK) {
4425 get_stack (idf, out, ref, "A68_REF");
4426 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[%d]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field)));
4427 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
4428 }
4429 inline_unit (src, out, L_EXECUTE);
4430 /* Generate */
4431 compile_assign (src, out, sel);
4432 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
4433 if (compose_fun == A68_MAKE_FUNCTION) {
4434 (void) make_name (fn, "_void_assign", "", NUMBER (p));
4435 write_fun_postlude (p, out, fn);
4436 }
4437 return (fn);
4438 } else {
4439 return (NO_TEXT);
4440 }
4441 }
4442
4443 /**
4444 @brief Compile voiding assignation.
4445 @param p Starting node.
4446 @param out Output file descriptor.
4447 @param compose_fun Whether to compose a function.
4448 @return Function name.
4449 **/
4450
4451 static char *
compile_voiding_assignation_slice(NODE_T * p,FILE_T out,int compose_fun)4452 compile_voiding_assignation_slice (NODE_T * p, FILE_T out, int compose_fun)
4453 {
4454 NODE_T *dst = SUB (locate (p, ASSIGNATION));
4455 NODE_T *src = NEXT_NEXT (dst);
4456 NODE_T *slice = locate (SUB (dst), SLICE);
4457 NODE_T *prim = SUB (slice);
4458 MOID_T *mode = SUB_MOID (dst);
4459 MOID_T *row_mode = DEFLEX (MOID (prim));
4460 if (IS (row_mode, REF_SYMBOL) && basic_slice (slice) && basic_unit (src) && basic_mode_non_row (MOID (src))) {
4461 NODE_T *indx = NEXT (prim);
4462 char *symbol = NSYMBOL (SUB (prim));
4463 char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE], pop[NAME_SIZE];
4464 static char fn[NAME_SIZE];
4465 int k;
4466 comment_source (p, out);
4467 (void) make_name (pop, PUP, "", NUMBER (p));
4468 (void) make_name (fn, "_void_assign", "", NUMBER (p));
4469 if (compose_fun == A68_MAKE_FUNCTION) {
4470 write_fun_prelude (p, out, fn);
4471 }
4472 /* Declare */
4473 root_idf = NO_DEC;
4474 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
4475 if (signed_in (BOOK_DECL, L_DECLARE, symbol) == NO_BOOK) {
4476 (void) make_name (idf, symbol, "", NUMBER (prim));
4477 (void) make_name (arr, ARR, "", NUMBER (prim));
4478 (void) make_name (tup, TUP, "", NUMBER (prim));
4479 (void) make_name (elm, ELM, "", NUMBER (prim));
4480 (void) make_name (drf, DRF, "", NUMBER (prim));
4481 (void) add_declaration (&root_idf, "A68_REF", 1, idf);
4482 (void) add_declaration (&root_idf, "A68_REF", 0, elm);
4483 (void) add_declaration (&root_idf, "A68_ARRAY", 1, arr);
4484 (void) add_declaration (&root_idf, "A68_TUPLE", 1, tup);
4485 (void) add_declaration (&root_idf, inline_mode (mode), 1, drf);
4486 sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
4487 } else {
4488 int n = NUMBER (signed_in (BOOK_DECL, L_EXECUTE, symbol));
4489 (void) make_name (idf, symbol, "", n);
4490 (void) make_name (arr, ARR, "", n);
4491 (void) make_name (tup, TUP, "", n);
4492 (void) make_name (elm, ELM, "", n);
4493 (void) make_name (drf, DRF, "", n);
4494 }
4495 k = 0;
4496 inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
4497 inline_unit (src, out, L_DECLARE);
4498 print_declarations (out, root_idf);
4499 /* Initialise */
4500 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
4501 if (signed_in (BOOK_DECL, L_EXECUTE, symbol) == NO_BOOK) {
4502 NODE_T *pidf = locate (prim, IDENTIFIER);
4503 get_stack (pidf, out, idf, "A68_REF");
4504 indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
4505 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
4506 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
4507 }
4508 k = 0;
4509 inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
4510 indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
4511 k = 0;
4512 inline_indexer (indx, out, L_YIELD, &k, tup);
4513 undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n"));
4514 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
4515 inline_unit (src, out, L_EXECUTE);
4516 /* Generate */
4517 compile_assign (src, out, drf);
4518 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
4519 if (compose_fun == A68_MAKE_FUNCTION) {
4520 (void) make_name (fn, "_void_assign", "", NUMBER (p));
4521 write_fun_postlude (p, out, fn);
4522 }
4523 return (fn);
4524 } else {
4525 return (NO_TEXT);
4526 }
4527 }
4528
4529 /**
4530 @brief Compile voiding assignation.
4531 @param p Starting node.
4532 @param out Output file descriptor.
4533 @param compose_fun Whether to compose a function.
4534 @return Function name.
4535 **/
4536
4537 static char *
compile_voiding_assignation_identifier(NODE_T * p,FILE_T out,int compose_fun)4538 compile_voiding_assignation_identifier (NODE_T * p, FILE_T out, int compose_fun)
4539 {
4540 NODE_T *dst = SUB (locate (p, ASSIGNATION));
4541 NODE_T *src = NEXT_NEXT (dst);
4542 if (BASIC (dst, IDENTIFIER) && basic_unit (src) && basic_mode_non_row (MOID (src))) {
4543 static char fn[NAME_SIZE];
4544 char idf[NAME_SIZE], pop[NAME_SIZE];
4545 NODE_T *q = locate (dst, IDENTIFIER);
4546 /* Declare */
4547 (void) make_name (pop, PUP, "", NUMBER (p));
4548 comment_source (p, out);
4549 (void) make_name (fn, "_void_assign", "", NUMBER (p));
4550 if (compose_fun == A68_MAKE_FUNCTION) {
4551 write_fun_prelude (p, out, fn);
4552 }
4553 root_idf = NO_DEC;
4554 if (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)) == NO_BOOK) {
4555 (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
4556 (void) add_declaration (&root_idf, inline_mode (SUB_MOID (dst)), 1, idf);
4557 sign_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q), NULL, NUMBER (p));
4558 } else {
4559 (void) make_name (idf, NSYMBOL (q), "", NUMBER (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (p))));
4560 }
4561 inline_unit (dst, out, L_DECLARE);
4562 inline_unit (src, out, L_DECLARE);
4563 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
4564 print_declarations (out, root_idf);
4565 /* Initialise */
4566 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
4567 inline_unit (dst, out, L_EXECUTE);
4568 if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) == NO_BOOK) {
4569 if (BODY (TAX (q)) != NO_TAG) {
4570 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) LOCAL_ADDRESS (", idf, inline_mode (SUB_MOID (dst))));
4571 inline_unit (dst, out, L_YIELD);
4572 undent (out, ");\n");
4573 sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q), NULL, NUMBER (p));
4574 } else {
4575 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, ", idf, inline_mode (SUB_MOID (dst))));
4576 inline_unit (dst, out, L_YIELD);
4577 undent (out, ");\n");
4578 sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q), NULL, NUMBER (p));
4579 }
4580 }
4581 inline_unit (src, out, L_EXECUTE);
4582 compile_assign (src, out, idf);
4583 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
4584 if (compose_fun == A68_MAKE_FUNCTION) {
4585 (void) make_name (fn, "_void_assign", "", NUMBER (p));
4586 write_fun_postlude (p, out, fn);
4587 }
4588 return (fn);
4589 } else {
4590 return (NO_TEXT);
4591 }
4592 }
4593
4594 /**
4595 @brief Compile identity-relation.
4596 @param p Starting node.
4597 @param out Output file descriptor.
4598 @param compose_fun Whether to compose a function.
4599 @return Function name.
4600 **/
4601
4602 static char *
compile_identity_relation(NODE_T * p,FILE_T out,int compose_fun)4603 compile_identity_relation (NODE_T * p, FILE_T out, int compose_fun)
4604 {
4605 #define GOOD(p) (locate (p, IDENTIFIER) != NO_NODE && IS (MOID (locate ((p), IDENTIFIER)), REF_SYMBOL))
4606 NODE_T *lhs = SUB (p);
4607 NODE_T *op = NEXT (lhs);
4608 NODE_T *rhs = NEXT (op);
4609 if (GOOD (lhs) && GOOD (rhs)) {
4610 static char fn[NAME_SIZE];
4611 comment_source (p, out);
4612 (void) make_name (fn, "_identity", "", NUMBER (p));
4613 if (compose_fun == A68_MAKE_FUNCTION) {
4614 write_fun_prelude (p, out, fn);
4615 }
4616 root_idf = NO_DEC;
4617 inline_identity_relation (p, out, L_DECLARE);
4618 print_declarations (out, root_idf);
4619 inline_identity_relation (p, out, L_EXECUTE);
4620 indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, "));
4621 inline_identity_relation (p, out, L_YIELD);
4622 undentf (out, snprintf (line, SNPRINTF_SIZE, ", A68_BOOL);\n"));
4623 if (compose_fun == A68_MAKE_FUNCTION) {
4624 (void) make_name (fn, "_identity", "", NUMBER (p));
4625 write_fun_postlude (p, out, fn);
4626 }
4627 return (fn);
4628 } else if (GOOD (lhs) && locate (rhs, NIHIL) != NO_NODE) {
4629 static char fn[NAME_SIZE];
4630 comment_source (p, out);
4631 (void) make_name (fn, "_identity", "", NUMBER (p));
4632 if (compose_fun == A68_MAKE_FUNCTION) {
4633 write_fun_prelude (p, out, fn);
4634 }
4635 root_idf = NO_DEC;
4636 inline_identity_relation (p, out, L_DECLARE);
4637 print_declarations (out, root_idf);
4638 inline_identity_relation (p, out, L_EXECUTE);
4639 indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, "));
4640 inline_identity_relation (p, out, L_YIELD);
4641 undentf (out, snprintf (line, SNPRINTF_SIZE, ", A68_BOOL);\n"));
4642 if (compose_fun == A68_MAKE_FUNCTION) {
4643 (void) make_name (fn, "_identity", "", NUMBER (p));
4644 write_fun_postlude (p, out, fn);
4645 }
4646 return (fn);
4647 } else {
4648 return (NO_TEXT);
4649 }
4650 #undef GOOD
4651 }
4652
4653 /**
4654 @brief Compile closed clause.
4655 @param out Output file descriptor.
4656 @param decs Number of declarations.
4657 @param pop Value to restore stack pointer to.
4658 @param p Starting node.
4659 **/
4660
4661 static void
compile_declaration_list(NODE_T * p,FILE_T out,int * decs,char * pop)4662 compile_declaration_list (NODE_T * p, FILE_T out, int *decs, char *pop)
4663 {
4664 for (; p != NO_NODE; FORWARD (p)) {
4665 switch (ATTRIBUTE (p)) {
4666 case MODE_DECLARATION:
4667 case PROCEDURE_DECLARATION:
4668 case BRIEF_OPERATOR_DECLARATION:
4669 case PRIORITY_DECLARATION:
4670 {
4671 /* No action needed */
4672 (*decs)++;
4673 return;
4674 }
4675 case OPERATOR_DECLARATION:
4676 {
4677 indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_operator_dec (_N_ (%d));", NUMBER (SUB (p))));
4678 inline_comment_source (p, out);
4679 undent (out, NEWLINE_STRING);
4680 (*decs)++;
4681 break;
4682 }
4683 case IDENTITY_DECLARATION:
4684 {
4685 indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_identity_dec (_N_ (%d));", NUMBER (SUB (p))));
4686 inline_comment_source (p, out);
4687 undent (out, NEWLINE_STRING);
4688 (*decs)++;
4689 break;
4690 }
4691 case VARIABLE_DECLARATION:
4692 {
4693 char declarer[NAME_SIZE];
4694 (void) make_name (declarer, DEC, "", NUMBER (SUB (p)));
4695 indent (out, "{");
4696 inline_comment_source (p, out);
4697 undent (out, NEWLINE_STRING);
4698 indentation++;
4699 indentf (out, snprintf (line, SNPRINTF_SIZE, "NODE_T *%s = NO_NODE;\n", declarer));
4700 indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_variable_dec (_N_ (%d), &%s, stack_pointer);\n", NUMBER (SUB (p)), declarer));
4701 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
4702 indentation--;
4703 indent (out, "}\n");
4704 (*decs)++;
4705 break;
4706 }
4707 case PROCEDURE_VARIABLE_DECLARATION:
4708 {
4709 indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_proc_variable_dec (_N_ (%d));", NUMBER (SUB (p))));
4710 inline_comment_source (p, out);
4711 undent (out, NEWLINE_STRING);
4712 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
4713 (*decs)++;
4714 break;
4715 }
4716 default:
4717 {
4718 compile_declaration_list (SUB (p), out, decs, pop);
4719 break;
4720 }
4721 }
4722 }
4723 }
4724
4725 /**
4726 @brief Compile closed clause.
4727 @param p Starting node.
4728 @param out Output file descriptor.
4729 @param last Last unit generated.
4730 @param units Number of units.
4731 @param decs Number of declarations.
4732 @param pop Value to restore stack pointer to.
4733 @param compose_fun Whether to compose a function.
4734 **/
4735
4736 static void
compile_serial_clause(NODE_T * p,FILE_T out,NODE_T ** last,int * units,int * decs,char * pop,int compose_fun)4737 compile_serial_clause (NODE_T * p, FILE_T out, NODE_T ** last, int *units, int *decs, char *pop, int compose_fun)
4738 {
4739 for (; p != NO_NODE; FORWARD (p)) {
4740 if (compose_fun == A68_MAKE_OTHERS) {
4741 if (IS (p, UNIT)) {
4742 (*units)++;
4743 }
4744 if (IS (p, DECLARATION_LIST)) {
4745 (*decs)++;
4746 }
4747 if (IS (p, UNIT) || IS (p, DECLARATION_LIST)) {
4748 if (compile_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) {
4749 if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) {
4750 compile_units (SUB_SUB (p), out);
4751 } else {
4752 compile_units (SUB (p), out);
4753 }
4754 } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
4755 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
4756 COMPILE_NAME (GINFO (p)) = COMPILE_NAME (GINFO (SUB (p)));
4757 }
4758 return;
4759 } else {
4760 compile_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun);
4761 }
4762 } else
4763 switch (ATTRIBUTE (p)) {
4764 case UNIT:
4765 {
4766 (*last) = p;
4767 CODE_EXECUTE (p);
4768 inline_comment_source (p, out);
4769 undent (out, NEWLINE_STRING);
4770 (*units)++;
4771 return;
4772 }
4773 case SEMI_SYMBOL:
4774 {
4775 if (IS (*last, UNIT) && MOID (*last) == MODE (VOID)) {
4776 break;
4777 } else if (IS (*last, DECLARATION_LIST)) {
4778 break;
4779 } else {
4780 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
4781 }
4782 break;
4783 }
4784 case DECLARATION_LIST:
4785 {
4786 (*last) = p;
4787 compile_declaration_list (SUB (p), out, decs, pop);
4788 break;
4789 }
4790 default:
4791 {
4792 compile_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun);
4793 break;
4794 }
4795 }
4796 }
4797 }
4798
4799 /**
4800 @brief Embed serial clause.
4801 @param p Starting node.
4802 @param out Output file descriptor.
4803 @param pop Value to restore stack pointer to.
4804 */
4805
4806 static void
embed_serial_clause(NODE_T * p,FILE_T out,char * pop)4807 embed_serial_clause (NODE_T * p, FILE_T out, char *pop)
4808 {
4809 NODE_T *last = NO_NODE;
4810 int units = 0, decs = 0;
4811 indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_N_ (%d));\n", NUMBER (p)));
4812 init_static_frame (out, p);
4813 compile_serial_clause (p, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION);
4814 indent (out, "CLOSE_FRAME;\n");
4815 }
4816
4817 /**
4818 @brief Compile code clause.
4819 @param out Output file descriptor.
4820 @param p Starting node.
4821 @param compose_fun Whether to compose a function.
4822 @return Function name.
4823 **/
4824
4825 static char *
compile_code_clause(NODE_T * p,FILE_T out,int compose_fun)4826 compile_code_clause (NODE_T * p, FILE_T out, int compose_fun)
4827 {
4828 static char fn[NAME_SIZE];
4829 comment_source (p, out);
4830 (void) make_name (fn, "_code", "", NUMBER (p));
4831 if (compose_fun == A68_MAKE_FUNCTION) {
4832 write_fun_prelude (p, out, fn);
4833 }
4834 embed_code_clause (SUB (p), out);
4835 if (compose_fun == A68_MAKE_FUNCTION) {
4836 (void) make_name (fn, "_code", "", NUMBER (p));
4837 write_fun_postlude (p, out, fn);
4838 }
4839 return (fn);
4840 }
4841
4842 /**
4843 @brief Compile closed clause.
4844 @param out Output file descriptor.
4845 @param p Starting node.
4846 @param compose_fun Whether to compose a function.
4847 @return Function name.
4848 **/
4849
4850 static char *
compile_closed_clause(NODE_T * p,FILE_T out,int compose_fun)4851 compile_closed_clause (NODE_T * p, FILE_T out, int compose_fun)
4852 {
4853 NODE_T *sc = NEXT_SUB (p);
4854 if (MOID (p) == MODE (VOID) && LABELS (TABLE (sc)) == NO_TAG) {
4855 static char fn[NAME_SIZE];
4856 char pop[NAME_SIZE];
4857 int units = 0, decs = 0;
4858 NODE_T *last = NO_NODE;
4859 compile_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
4860 (void) make_name (pop, PUP, "", NUMBER (p));
4861 comment_source (p, out);
4862 (void) make_name (fn, "_closed", "", NUMBER (p));
4863 if (compose_fun == A68_MAKE_FUNCTION) {
4864 write_fun_prelude (p, out, fn);
4865 }
4866 root_idf = NO_DEC;
4867 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
4868 print_declarations (out, root_idf);
4869 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
4870 embed_serial_clause (sc, out, pop);
4871 if (compose_fun == A68_MAKE_FUNCTION) {
4872 (void) make_name (fn, "_closed", "", NUMBER (p));
4873 write_fun_postlude (p, out, fn);
4874 }
4875 return (fn);
4876 } else {
4877 return (NO_TEXT);
4878 }
4879 }
4880
4881 /**
4882 @brief Compile collateral clause.
4883 @param p Starting node.
4884 @param out Output file descriptor.
4885 @param compose_fun Whether to compose a function.
4886 @return Function name.
4887 **/
4888
4889 static char *
compile_collateral_clause(NODE_T * p,FILE_T out,int compose_fun)4890 compile_collateral_clause (NODE_T * p, FILE_T out, int compose_fun)
4891 {
4892 if (basic_unit (p) && IS (MOID (p), STRUCT_SYMBOL)) {
4893 static char fn[NAME_SIZE];
4894 comment_source (p, out);
4895 (void) make_name (fn, "_collateral", "", NUMBER (p));
4896 if (compose_fun == A68_MAKE_FUNCTION) {
4897 write_fun_prelude (p, out, fn);
4898 }
4899 root_idf = NO_DEC;
4900 inline_collateral_units (NEXT_SUB (p), out, L_DECLARE);
4901 print_declarations (out, root_idf);
4902 inline_collateral_units (NEXT_SUB (p), out, L_EXECUTE);
4903 inline_collateral_units (NEXT_SUB (p), out, L_YIELD);
4904 if (compose_fun == A68_MAKE_FUNCTION) {
4905 (void) make_name (fn, "_collateral", "", NUMBER (p));
4906 write_fun_postlude (p, out, fn);
4907 }
4908 return (fn);
4909 } else {
4910 return (NO_TEXT);
4911 }
4912 }
4913
4914 /**
4915 @brief Compile conditional clause.
4916 @param out Output file descriptor.
4917 @param p Starting node.
4918 @param compose_fun Whether to compose a function.
4919 @return Function name.
4920 **/
4921
4922 static char *
compile_basic_conditional(NODE_T * p,FILE_T out,int compose_fun)4923 compile_basic_conditional (NODE_T * p, FILE_T out, int compose_fun)
4924 {
4925 static char fn[NAME_SIZE];
4926 NODE_T *q = SUB (p);
4927 if (!(basic_mode (MOID (p)) || MOID (p) == MODE (VOID))) {
4928 return (NO_TEXT);
4929 }
4930 p = q;
4931 if (!basic_conditional (p)) {
4932 return (NO_TEXT);
4933 }
4934 comment_source (p, out);
4935 (void) make_name (fn, "_conditional", "", NUMBER (q));
4936 if (compose_fun == A68_MAKE_FUNCTION) {
4937 write_fun_prelude (q, out, fn);
4938 }
4939 /* Collect declarations */
4940 if (IS (p, IF_PART) || IS (p, OPEN_PART)) {
4941 root_idf = NO_DEC;
4942 inline_unit (SUB (NEXT_SUB (p)), out, L_DECLARE);
4943 print_declarations (out, root_idf);
4944 inline_unit (SUB (NEXT_SUB (p)), out, L_EXECUTE);
4945 indent (out, "if (");
4946 inline_unit (SUB (NEXT_SUB (p)), out, L_YIELD);
4947 undent (out, ") {\n");
4948 indentation++;
4949 } else {
4950 ABEND (A68_TRUE, "if-part expected", NO_TEXT);
4951 }
4952 FORWARD (p);
4953 if (IS (p, THEN_PART) || IS (p, CHOICE)) {
4954 int pop = temp_book_pointer;
4955 (void) compile_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING);
4956 indentation--;
4957 temp_book_pointer = pop;
4958 } else {
4959 ABEND (A68_TRUE, "then-part expected", NO_TEXT);
4960 }
4961 FORWARD (p);
4962 if (IS (p, ELSE_PART) || IS (p, CHOICE)) {
4963 int pop = temp_book_pointer;
4964 indent (out, "} else {\n");
4965 indentation++;
4966 (void) compile_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING);
4967 indentation--;
4968 temp_book_pointer = pop;
4969 }
4970 /* Done */
4971 indent (out, "}\n");
4972 if (compose_fun == A68_MAKE_FUNCTION) {
4973 (void) make_name (fn, "_conditional", "", NUMBER (q));
4974 write_fun_postlude (q, out, fn);
4975 }
4976 return (fn);
4977 }
4978
4979 /**
4980 @brief Compile conditional clause.
4981 @param p Starting node.
4982 @param out Output file descriptor.
4983 @param compose_fun Whether to compose a function.
4984 @return Function name.
4985 **/
4986
4987 static char *
compile_conditional_clause(NODE_T * p,FILE_T out,int compose_fun)4988 compile_conditional_clause (NODE_T * p, FILE_T out, int compose_fun)
4989 {
4990 static char fn[NAME_SIZE];
4991 char pop[NAME_SIZE];
4992 int units = 0, decs = 0;
4993 NODE_T *q, *last;
4994 /* We only compile IF basic unit or ELIF basic unit, so we save on opening frames */
4995 /* Check worthiness of the clause */
4996 if (MOID (p) != MODE (VOID)) {
4997 return (NO_TEXT);
4998 }
4999 q = SUB (p);
5000 while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
5001 if (!basic_serial (NEXT_SUB (q), 1)) {
5002 return (NO_TEXT);
5003 }
5004 FORWARD (q);
5005 while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
5006 if (LABELS (TABLE (NEXT_SUB (q))) != NO_TAG) {
5007 return (NO_TEXT);
5008 }
5009 FORWARD (q);
5010 }
5011 if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
5012 q = SUB (q);
5013 } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) {
5014 FORWARD (q);
5015 }
5016 }
5017 /* Generate embedded units */
5018 q = SUB (p);
5019 while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
5020 FORWARD (q);
5021 while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
5022 last = NO_NODE;
5023 units = decs = 0;
5024 compile_serial_clause (NEXT_SUB (q), out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
5025 FORWARD (q);
5026 }
5027 if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
5028 q = SUB (q);
5029 } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) {
5030 FORWARD (q);
5031 }
5032 }
5033 /* Prep and Dec */
5034 (void) make_name (fn, "_conditional", "", NUMBER (p));
5035 (void) make_name (pop, PUP, "", NUMBER (p));
5036 comment_source (p, out);
5037 if (compose_fun == A68_MAKE_FUNCTION) {
5038 write_fun_prelude (p, out, fn);
5039 }
5040 root_idf = NO_DEC;
5041 q = SUB (p);
5042 while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
5043 inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE);
5044 FORWARD (q);
5045 while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
5046 FORWARD (q);
5047 }
5048 if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
5049 q = SUB (q);
5050 } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) {
5051 FORWARD (q);
5052 }
5053 }
5054 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
5055 print_declarations (out, root_idf);
5056 /* Generate the function body */
5057 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
5058 q = SUB (p);
5059 while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
5060 inline_unit (SUB (NEXT_SUB (q)), out, L_EXECUTE);
5061 FORWARD (q);
5062 while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
5063 FORWARD (q);
5064 }
5065 if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
5066 q = SUB (q);
5067 } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) {
5068 FORWARD (q);
5069 }
5070 }
5071 q = SUB (p);
5072 while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
5073 BOOL_T else_part = A68_FALSE;
5074 if (is_one_of (q, IF_PART, OPEN_PART, STOP)) {
5075 indent (out, "if (");
5076 } else {
5077 indent (out, "} else if (");
5078 }
5079 inline_unit (SUB (NEXT_SUB (q)), out, L_YIELD);
5080 undent (out, ") {\n");
5081 FORWARD (q);
5082 while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
5083 if (else_part) {
5084 indent (out, "} else {\n");
5085 }
5086 indentation++;
5087 embed_serial_clause (NEXT_SUB (q), out, pop);
5088 indentation--;
5089 else_part = A68_TRUE;
5090 FORWARD (q);
5091 }
5092 if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
5093 q = SUB (q);
5094 } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) {
5095 FORWARD (q);
5096 }
5097 }
5098 indent (out, "}\n");
5099 if (compose_fun == A68_MAKE_FUNCTION) {
5100 (void) make_name (fn, "_conditional", "", NUMBER (p));
5101 write_fun_postlude (p, out, fn);
5102 }
5103 return (fn);
5104 }
5105
5106 /**
5107 @brief Compile unit from integral-case in-part.
5108 @param p Node in syntax tree.
5109 @param out Output file descriptor.
5110 @param sym Node in syntax tree.
5111 @param k Value of enquiry clause.
5112 @param count Unit counter.
5113 @param compose_fun Whether to compose a function.
5114 @return Whether a unit was compiled.
5115 **/
5116
5117 BOOL_T
compile_int_case_units(NODE_T * p,FILE_T out,NODE_T * sym,int k,int * count,int compose_fun)5118 compile_int_case_units (NODE_T * p, FILE_T out, NODE_T * sym, int k, int *count, int compose_fun)
5119 {
5120 if (p == NO_NODE) {
5121 return (A68_FALSE);
5122 } else {
5123 if (IS (p, UNIT)) {
5124 if (k == *count) {
5125 if (compose_fun == A68_MAKE_FUNCTION) {
5126 indentf (out, snprintf (line, SNPRINTF_SIZE, "case %d: {\n", k));
5127 indentation++;
5128 indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_N_ (%d));\n", NUMBER (sym)));
5129 CODE_EXECUTE (p);
5130 inline_comment_source (p, out);
5131 undent (out, NEWLINE_STRING);
5132 indent (out, "CLOSE_FRAME;\n");
5133 indent (out, "break;\n");
5134 indentation--;
5135 indent (out, "}\n");
5136 } else if (compose_fun == A68_MAKE_OTHERS) {
5137 if (compile_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) {
5138 if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) {
5139 compile_units (SUB_SUB (p), out);
5140 } else {
5141 compile_units (SUB (p), out);
5142 }
5143 } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
5144 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
5145 COMPILE_NAME (GINFO (p)) = COMPILE_NAME (GINFO (SUB (p)));
5146 }
5147 }
5148 return (A68_TRUE);
5149 } else {
5150 (*count)++;
5151 return (A68_FALSE);
5152 }
5153 } else {
5154 if (compile_int_case_units (SUB (p), out, sym, k, count, compose_fun)) {
5155 return (A68_TRUE);
5156 } else {
5157 return (compile_int_case_units (NEXT (p), out, sym, k, count, compose_fun));
5158 }
5159 }
5160 }
5161 }
5162
5163 /**
5164 @brief Compile integral-case-clause.
5165 @param p Node in syntax tree.
5166 @param out Output file descriptor.
5167 @param compose_fun Whether to compose a function.
5168 **/
5169
5170 static char *
compile_int_case_clause(NODE_T * p,FILE_T out,int compose_fun)5171 compile_int_case_clause (NODE_T * p, FILE_T out, int compose_fun)
5172 {
5173 static char fn[NAME_SIZE];
5174 char pop[NAME_SIZE];
5175 int units = 0, decs = 0, k = 0, count = 0;
5176 NODE_T *q, *last;
5177 /* We only compile CASE basic unit */
5178 /* Check worthiness of the clause */
5179 if (MOID (p) != MODE (VOID)) {
5180 return (NO_TEXT);
5181 }
5182 q = SUB (p);
5183 if (q != NO_NODE && is_one_of (q, CASE_PART, OPEN_PART, STOP)) {
5184 if (!basic_serial (NEXT_SUB (q), 1)) {
5185 return (NO_TEXT);
5186 }
5187 FORWARD (q);
5188 } else {
5189 return (NO_TEXT);
5190 }
5191 while (q != NO_NODE && is_one_of (q, CASE_IN_PART, OUT_PART, CHOICE, STOP)) {
5192 if (LABELS (TABLE (NEXT_SUB (q))) != NO_TAG) {
5193 return (NO_TEXT);
5194 }
5195 FORWARD (q);
5196 }
5197 if (q != NO_NODE && is_one_of (q, ESAC_SYMBOL, CLOSE_SYMBOL)) {
5198 FORWARD (q);
5199 } else {
5200 return (NO_TEXT);
5201 }
5202 /* Generate embedded units */
5203 q = SUB (p);
5204 if (q != NO_NODE && is_one_of (q, CASE_PART, OPEN_PART, STOP)) {
5205 FORWARD (q);
5206 if (q != NO_NODE && is_one_of (q, CASE_IN_PART, CHOICE, STOP)) {
5207 last = NO_NODE;
5208 units = decs = 0;
5209 k = 0;
5210 do {
5211 count = 1;
5212 k++;
5213 } while (compile_int_case_units (NEXT_SUB (q), out, NO_NODE, k, &count, A68_MAKE_OTHERS));
5214 FORWARD (q);
5215 }
5216 if (q != NO_NODE && is_one_of (q, OUT_PART, CHOICE, STOP)) {
5217 last = NO_NODE;
5218 units = decs = 0;
5219 compile_serial_clause (NEXT_SUB (q), out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
5220 FORWARD (q);
5221 }
5222 }
5223 /* Prep and Dec */
5224 (void) make_name (pop, PUP, "", NUMBER (p));
5225 comment_source (p, out);
5226 (void) make_name (fn, "_case", "", NUMBER (p));
5227 if (compose_fun == A68_MAKE_FUNCTION) {
5228 write_fun_prelude (p, out, fn);
5229 }
5230 root_idf = NO_DEC;
5231 q = SUB (p);
5232 inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE);
5233 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
5234 print_declarations (out, root_idf);
5235 /* Generate the function body */
5236 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
5237 q = SUB (p);
5238 inline_unit (SUB (NEXT_SUB (q)), out, L_EXECUTE);
5239 indent (out, "switch (");
5240 inline_unit (SUB (NEXT_SUB (q)), out, L_YIELD);
5241 undent (out, ") {\n");
5242 indentation++;
5243 FORWARD (q);
5244 k = 0;
5245 do {
5246 count = 1;
5247 k++;
5248 } while (compile_int_case_units (NEXT_SUB (q), out, SUB (q), k, &count, A68_MAKE_FUNCTION));
5249 FORWARD (q);
5250 if (q != NO_NODE && is_one_of (q, OUT_PART, CHOICE, STOP)) {
5251 indent (out, "default: {\n");
5252 indentation++;
5253 embed_serial_clause (NEXT_SUB (q), out, pop);
5254 indent (out, "break;\n");
5255 indentation--;
5256 indent (out, "}\n");
5257 }
5258 indentation--;
5259 indent (out, "}\n");
5260 if (compose_fun == A68_MAKE_FUNCTION) {
5261 (void) make_name (fn, "_case", "", NUMBER (p));
5262 write_fun_postlude (p, out, fn);
5263 }
5264 return (fn);
5265 }
5266
5267 /**
5268 @brief Compile loop clause.
5269 @param out Output file descriptor.
5270 @param p Starting node.
5271 @param compose_fun Whether to compose a function.
5272 @return Function name.
5273 **/
5274
5275 static char *
compile_loop_clause(NODE_T * p,FILE_T out,int compose_fun)5276 compile_loop_clause (NODE_T * p, FILE_T out, int compose_fun)
5277 {
5278 NODE_T *for_part = NO_NODE, *from_part = NO_NODE, *by_part = NO_NODE, *to_part = NO_NODE, *downto_part = NO_NODE, *while_part = NO_NODE, *sc;
5279 static char fn[NAME_SIZE];
5280 char idf[NAME_SIZE], z[NAME_SIZE], pop[NAME_SIZE];
5281 NODE_T *q = SUB (p), *last = NO_NODE;
5282 int units, decs;
5283 BOOL_T gc, need_reinit;
5284 /* FOR identifier */
5285 if (IS (q, FOR_PART)) {
5286 for_part = NEXT_SUB (q);
5287 FORWARD (q);
5288 }
5289 /* FROM unit */
5290 if (IS (p, FROM_PART)) {
5291 from_part = NEXT_SUB (q);
5292 if (!basic_unit (from_part)) {
5293 return (NO_TEXT);
5294 }
5295 FORWARD (q);
5296 }
5297 /* BY unit */
5298 if (IS (q, BY_PART)) {
5299 by_part = NEXT_SUB (q);
5300 if (!basic_unit (by_part)) {
5301 return (NO_TEXT);
5302 }
5303 FORWARD (q);
5304 }
5305 /* TO unit, DOWNTO unit */
5306 if (IS (q, TO_PART)) {
5307 if (IS (SUB (q), TO_SYMBOL)) {
5308 to_part = NEXT_SUB (q);
5309 if (!basic_unit (to_part)) {
5310 return (NO_TEXT);
5311 }
5312 } else if (IS (SUB (q), DOWNTO_SYMBOL)) {
5313 downto_part = NEXT_SUB (q);
5314 if (!basic_unit (downto_part)) {
5315 return (NO_TEXT);
5316 }
5317 }
5318 FORWARD (q);
5319 }
5320 /* WHILE DO OD is not yet supported */
5321 if (IS (q, WHILE_PART)) {
5322 return (NO_TEXT);
5323 }
5324 /* DO UNTIL OD is not yet supported */
5325 if (IS (q, DO_PART) || IS (q, ALT_DO_PART)) {
5326 sc = q = NEXT_SUB (q);
5327 if (IS (q, SERIAL_CLAUSE)) {
5328 FORWARD (q);
5329 }
5330 if (q != NO_NODE && IS (q, UNTIL_PART)) {
5331 return (NO_TEXT);
5332 }
5333 } else {
5334 return (NO_TEXT);
5335 }
5336 if (LABELS (TABLE (sc)) != NO_TAG) {
5337 return (NO_TEXT);
5338 }
5339 /* Loop clause is compiled */
5340 units = decs = 0;
5341 compile_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
5342 gc = (decs > 0);
5343 comment_source (p, out);
5344 (void) make_name (fn, "_loop", "", NUMBER (p));
5345 if (compose_fun == A68_MAKE_FUNCTION) {
5346 write_fun_prelude (p, out, fn);
5347 }
5348 root_idf = NO_DEC;
5349 (void) make_name (idf, "k", "", NUMBER (p));
5350 (void) add_declaration (&root_idf, "int", 0, idf);
5351 if (for_part != NO_NODE) {
5352 (void) make_name (z, "z", "", NUMBER (p));
5353 (void) add_declaration (&root_idf, "A68_INT", 1, z);
5354 }
5355 if (from_part != NO_NODE) {
5356 inline_unit (from_part, out, L_DECLARE);
5357 }
5358 if (by_part != NO_NODE) {
5359 inline_unit (by_part, out, L_DECLARE);
5360 }
5361 if (to_part != NO_NODE) {
5362 inline_unit (to_part, out, L_DECLARE);
5363 }
5364 if (downto_part != NO_NODE) {
5365 inline_unit (downto_part, out, L_DECLARE);
5366 }
5367 if (while_part != NO_NODE) {
5368 inline_unit (SUB (NEXT_SUB (while_part)), out, L_DECLARE);
5369 }
5370 (void) make_name (pop, PUP, "", NUMBER (p));
5371 (void) add_declaration (&root_idf, "ADDR_T", 0, pop);
5372 print_declarations (out, root_idf);
5373 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop));
5374 if (from_part != NO_NODE) {
5375 inline_unit (from_part, out, L_EXECUTE);
5376 }
5377 if (by_part != NO_NODE) {
5378 inline_unit (by_part, out, L_EXECUTE);
5379 }
5380 if (to_part != NO_NODE) {
5381 inline_unit (to_part, out, L_EXECUTE);
5382 }
5383 if (downto_part != NO_NODE) {
5384 inline_unit (downto_part, out, L_EXECUTE);
5385 }
5386 if (while_part != NO_NODE) {
5387 inline_unit (SUB (NEXT_SUB (while_part)), out, L_EXECUTE);
5388 }
5389 indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_N_ (%d));\n", NUMBER (sc)));
5390 init_static_frame (out, sc);
5391 if (for_part != NO_NODE) {
5392 indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (_N_ (%d)))));\n", z, NUMBER (for_part)));
5393 }
5394 /* The loop in C */
5395 /* Initialisation */
5396 indentf (out, snprintf (line, SNPRINTF_SIZE, "for (%s = ", idf));
5397 if (from_part == NO_NODE) {
5398 undent (out, "1");
5399 } else {
5400 inline_unit (from_part, out, L_YIELD);
5401 }
5402 undent (out, "; ");
5403 /* Condition */
5404 if (to_part == NO_NODE && downto_part == NO_NODE && while_part == NO_NODE) {
5405 undent (out, "A68_TRUE");
5406 } else {
5407 undent (out, idf);
5408 if (to_part != NO_NODE) {
5409 undent (out, " <= ");
5410 } else if (downto_part != NO_NODE) {
5411 undent (out, " >= ");
5412 }
5413 inline_unit (to_part, out, L_YIELD);
5414 }
5415 undent (out, "; ");
5416 /* Increment */
5417 if (by_part == NO_NODE) {
5418 undent (out, idf);
5419 if (to_part != NO_NODE) {
5420 undent (out, " ++");
5421 } else if (downto_part != NO_NODE) {
5422 undent (out, " --");
5423 } else {
5424 undent (out, " ++");
5425 }
5426 } else {
5427 undent (out, idf);
5428 if (to_part != NO_NODE) {
5429 undent (out, " += ");
5430 } else if (downto_part != NO_NODE) {
5431 undent (out, " -= ");
5432 } else {
5433 undent (out, " += ");
5434 }
5435 inline_unit (by_part, out, L_YIELD);
5436 }
5437 undent (out, ") {\n");
5438 indentation++;
5439 if (gc) {
5440 indent (out, "/* PREEMPTIVE_GC; */\n");
5441 }
5442 if (for_part != NO_NODE) {
5443 indentf (out, snprintf (line, SNPRINTF_SIZE, "_S_ (%s) = INIT_MASK;\n", z));
5444 indentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s) = %s;\n", z, idf));
5445 }
5446 units = decs = 0;
5447 compile_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION);
5448 /* Re-initialise if necessary */
5449 need_reinit = (BOOL_T) (AP_INCREMENT (TABLE (sc)) > 0 || need_initialise_frame (sc));
5450 if (need_reinit) {
5451 indent (out, "if (");
5452 if (to_part == NO_NODE && downto_part == NO_NODE) {
5453 undent (out, "A68_TRUE");
5454 } else {
5455 undent (out, idf);
5456 if (to_part != NO_NODE) {
5457 undent (out, " < ");
5458 } else if (downto_part != NO_NODE) {
5459 undent (out, " > ");
5460 }
5461 inline_unit (to_part, out, L_YIELD);
5462 }
5463 undent (out, ") {\n");
5464 indentation++;
5465 if (AP_INCREMENT (TABLE (sc)) > 0) {
5466 indentf (out, snprintf (line, SNPRINTF_SIZE, "FRAME_CLEAR (%d);\n", AP_INCREMENT (TABLE (sc))));
5467 }
5468 if (need_initialise_frame (sc)) {
5469 indentf (out, snprintf (line, SNPRINTF_SIZE, "initialise_frame (_N_ (%d));\n", NUMBER (sc)));
5470 }
5471 indentation--;
5472 indent (out, "}\n");
5473 }
5474 /* End of loop */
5475 indentation--;
5476 indent (out, "}\n");
5477 indent (out, "CLOSE_FRAME;\n");
5478 indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop));
5479 if (compose_fun == A68_MAKE_FUNCTION) {
5480 (void) make_name (fn, "_loop", "", NUMBER (p));
5481 write_fun_postlude (p, out, fn);
5482 }
5483 return (fn);
5484 }
5485
5486 /**
5487 @brief Compile serial units.
5488 @param out Output file descriptor.
5489 @param p Starting node.
5490 @param compose_fun Whether to compose a function.
5491 @return Function name.
5492 **/
5493
5494 static char *
compile_unit(NODE_T * p,FILE_T out,BOOL_T compose_fun)5495 compile_unit (NODE_T * p, FILE_T out, BOOL_T compose_fun)
5496 {
5497 /**/
5498 #define COMPILE(p, out, fun, compose_fun) {\
5499 char * fn = (fun) (p, out, compose_fun);\
5500 if (compose_fun == A68_MAKE_FUNCTION && fn != NO_TEXT) {\
5501 ABEND (strlen (fn) > 32, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);\
5502 COMPILE_NAME (GINFO (p)) = new_string (fn, NO_TEXT);\
5503 if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) {\
5504 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));\
5505 } else {\
5506 COMPILE_NODE (GINFO (p)) = NUMBER (p);\
5507 }\
5508 return (COMPILE_NAME (GINFO (p)));\
5509 } else {\
5510 COMPILE_NAME (GINFO (p)) = NO_TEXT;\
5511 COMPILE_NODE (GINFO (p)) = 0;\
5512 return (NO_TEXT);\
5513 }}
5514 /**/ LOW_SYSTEM_STACK_ALERT (p);
5515 if (p == NO_NODE) {
5516 return (NO_TEXT);
5517 } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, ENCLOSED_CLAUSE, STOP)) {
5518 COMPILE (SUB (p), out, compile_unit, compose_fun);
5519 }
5520 if (DEBUG_LEVEL >= 3) {
5521 /* Control structure */
5522 if (IS (p, CLOSED_CLAUSE)) {
5523 COMPILE (p, out, compile_closed_clause, compose_fun);
5524 } else if (IS (p, COLLATERAL_CLAUSE)) {
5525 COMPILE (p, out, compile_collateral_clause, compose_fun);
5526 } else if (IS (p, CONDITIONAL_CLAUSE)) {
5527 char *fn2 = compile_basic_conditional (p, out, compose_fun);
5528 if (compose_fun == A68_MAKE_FUNCTION && fn2 != NO_TEXT) {
5529 ABEND (strlen (fn2) > 32, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
5530 COMPILE_NAME (GINFO (p)) = new_string (fn2, NO_TEXT);
5531 if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) {
5532 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
5533 } else {
5534 COMPILE_NODE (GINFO (p)) = NUMBER (p);
5535 }
5536 return (COMPILE_NAME (GINFO (p)));
5537 } else {
5538 COMPILE (p, out, compile_conditional_clause, compose_fun);
5539 }
5540 } else if (IS (p, CASE_CLAUSE)) {
5541 COMPILE (p, out, compile_int_case_clause, compose_fun);
5542 } else if (IS (p, LOOP_CLAUSE)) {
5543 COMPILE (p, out, compile_loop_clause, compose_fun);
5544 }
5545 }
5546 if (DEBUG_LEVEL >= 2) {
5547 /* Simple constructions */
5548 if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), IDENTIFIER) != NO_NODE) {
5549 COMPILE (p, out, compile_voiding_assignation_identifier, compose_fun);
5550 } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SLICE) != NO_NODE) {
5551 COMPILE (p, out, compile_voiding_assignation_slice, compose_fun);
5552 } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SELECTION) != NO_NODE) {
5553 COMPILE (p, out, compile_voiding_assignation_selection, compose_fun);
5554 } else if (IS (p, SLICE)) {
5555 COMPILE (p, out, compile_slice, compose_fun);
5556 } else if (IS (p, DEREFERENCING) && locate (SUB (p), SLICE) != NO_NODE) {
5557 COMPILE (p, out, compile_dereference_slice, compose_fun);
5558 } else if (IS (p, SELECTION)) {
5559 COMPILE (p, out, compile_selection, compose_fun);
5560 } else if (IS (p, DEREFERENCING) && locate (SUB (p), SELECTION) != NO_NODE) {
5561 COMPILE (p, out, compile_dereference_selection, compose_fun);
5562 } else if (IS (p, CAST)) {
5563 COMPILE (p, out, compile_cast, compose_fun);
5564 } else if (IS (p, VOIDING) && IS (SUB (p), FORMULA)) {
5565 COMPILE (SUB (p), out, compile_voiding_formula, compose_fun);
5566 } else if (IS (p, VOIDING) && IS (SUB (p), MONADIC_FORMULA)) {
5567 COMPILE (SUB (p), out, compile_voiding_formula, compose_fun);
5568 } else if (IS (p, DEPROCEDURING)) {
5569 COMPILE (p, out, compile_deproceduring, compose_fun);
5570 } else if (IS (p, VOIDING) && IS (SUB (p), DEPROCEDURING)) {
5571 COMPILE (p, out, compile_voiding_deproceduring, compose_fun);
5572 } else if (IS (p, CALL)) {
5573 COMPILE (p, out, compile_call, compose_fun);
5574 } else if (IS (p, VOIDING) && IS (SUB (p), CALL)) {
5575 COMPILE (p, out, compile_voiding_call, compose_fun);
5576 } else if (IS (p, IDENTITY_RELATION)) {
5577 COMPILE (p, out, compile_identity_relation, compose_fun);
5578 } else if (IS (p, UNITING)) {
5579 COMPILE (p, out, compile_uniting, compose_fun);
5580 }
5581 }
5582 if (DEBUG_LEVEL >= 1) {
5583 /* Debugging stuff, only basic */
5584 if (IS (p, DENOTATION)) {
5585 COMPILE (p, out, compile_denotation, compose_fun);
5586 } else if (IS (p, IDENTIFIER)) {
5587 COMPILE (p, out, compile_identifier, compose_fun);
5588 } else if (IS (p, DEREFERENCING) && locate (SUB (p), IDENTIFIER) != NO_NODE) {
5589 COMPILE (p, out, compile_dereference_identifier, compose_fun);
5590 } else if (IS (p, MONADIC_FORMULA)) {
5591 COMPILE (p, out, compile_formula, compose_fun);
5592 } else if (IS (p, FORMULA)) {
5593 COMPILE (p, out, compile_formula, compose_fun);
5594 }
5595 }
5596 if (IS (p, CODE_CLAUSE)) {
5597 COMPILE (p, out, compile_code_clause, compose_fun);
5598 }
5599 return (NO_TEXT);
5600 #undef COMPILE
5601 }
5602
5603 /**
5604 @brief Compile units.
5605 @param p Starting node.
5606 @param out Output file descriptor.
5607 **/
5608
5609 void
compile_units(NODE_T * p,FILE_T out)5610 compile_units (NODE_T * p, FILE_T out)
5611 {
5612 ADDR_T pop_temp_heap_pointer = temp_heap_pointer; /* At the end we discard temporary declarations */
5613 for (; p != NO_NODE; FORWARD (p)) {
5614 if (IS (p, UNIT) || IS (p, CODE_CLAUSE)) {
5615 if (compile_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) {
5616 compile_units (SUB (p), out);
5617 } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
5618 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
5619 COMPILE_NAME (GINFO (p)) = COMPILE_NAME (GINFO (SUB (p)));
5620 }
5621 } else {
5622 compile_units (SUB (p), out);
5623 }
5624 }
5625 temp_heap_pointer = pop_temp_heap_pointer;
5626 }
5627
5628 /**
5629 @brief Compiler driver.
5630 @param out Output file descriptor.
5631 **/
5632
5633 void
compiler(FILE_T out)5634 compiler (FILE_T out)
5635 {
5636 if (OPTION_OPTIMISE (&program) == A68_FALSE) {
5637 return;
5638 }
5639 indentation = 0;
5640 temp_book_pointer = 0;
5641 root_idf = NO_DEC;
5642 global_level = A68_MAX_INT;
5643 global_pointer = 0;
5644 get_global_level (SUB (TOP_NODE (&program)));
5645 max_lex_lvl = 0;
5646 genie_preprocess (TOP_NODE (&program), &max_lex_lvl, NULL);
5647 write_prelude (out);
5648 get_global_level (TOP_NODE (&program));
5649 stack_pointer = stack_start;
5650 expr_stack_limit = stack_end - storage_overhead;
5651 compile_units (TOP_NODE (&program), out);
5652 ABEND (indentation != 0, "indentation error", NO_TEXT);
5653 }
5654