?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
a few more warnings
[suif.git] / src / basesuif / fixfortran / main.cc
bloba3d5593357080c9e41445b0f9dac15ac24b8e905
1 /* file "main.cc" of the fixfortran program for SUIF */
2
3 /* Copyright (c) 1994 Stanford University
4
5 All rights reserved.
6
7 This software is provided under the terms described in
8 the "suif_copyright.h" include file. */
9
10 #include <suif_copyright.h>
11
12 /*
13 * This file contains the main program for fixfortran. Many of the
14 * details of fixfortran are implemented here.
15 */
16
17 #define RCS_BASE_FILE main_cc
18
19 #include "fixfortran.h"
20 #include <limits.h>
21 #include <string.h>
22
23 RCS_BASE(
24 "$Id: main.cc,v 1.1.1.1 1998/06/16 15:17:24 brm Exp $")
25
26 INCLUDE_SUIF_COPYRIGHT
27
28 /*----------------------------------------------------------------------*
29 Begin Documentation
30 *----------------------------------------------------------------------*
31
32 Summary
33 -------
34
35 The fixfortran program is, along with sf2c and snoot, part of
36 the SUIF Fortran front end. It tries to undo some of the
37 changes sf2c makes in the code to write it in C. When
38 possible, fixfortran de-linearizes the array linearizations
39 sf2c does, inlines calls to max, min, absolute value, and
40 imaginary part functions, finds and marks common block
41 variables, and changes structures representing complex numbers
42 into arrays.
43
44
45 *----------------------------------------------------------------------*
46 End Documentation
47 *----------------------------------------------------------------------*/
48 /*----------------------------------------------------------------------*
49 Begin Private Type Definitions
50 *----------------------------------------------------------------------*/
51
52 /*----------------------------------------------------------------------*
53 End Private Type Definitions
54 *----------------------------------------------------------------------*/
55 /*----------------------------------------------------------------------*
56 Begin Public Global Variables
57 *----------------------------------------------------------------------*/
58
59 boolean errors = FALSE;
60 const char *k_io_read;
61 const char *k_io_write;
62
63 /*----------------------------------------------------------------------*
64 End Public Global Variables
65 *----------------------------------------------------------------------*/
66 /*----------------------------------------------------------------------*
67 Begin Private Global Variables
68 *----------------------------------------------------------------------*/
69
70 static size_t max_int_str_len;
71 static alist *aux_var_values;
72 static alist *array_types;
73 static const char *k_fixfortran_needed_aux;
74 static const char *k_fixfortran_fixed_array_type;
75 static const char *k_fixfortran_original_type;
76
77 /*----------------------------------------------------------------------*
78 End Private Global Variables
79 *----------------------------------------------------------------------*/
80 /*----------------------------------------------------------------------*
81 Begin Public Function Declarations
82 *----------------------------------------------------------------------*/
83
84 extern int main(int argc, char *argv[]);
85
86 /*----------------------------------------------------------------------*
87 End Public Function Declarations
88 *----------------------------------------------------------------------*/
89 /*----------------------------------------------------------------------*
90 Begin Private Function Declarations
91 *----------------------------------------------------------------------*/
92
93 static void mark_intrinsics(global_symtab *the_symtab);
94 static void do_proc(tree_proc *the_tree_proc);
95 static void de_linearize(tree_proc *the_proc);
96 void fix_array_type_for_base_expr(instruction *the_instr);
97 void fix_array_type_for_str_base_expr(instruction *the_instr);
98 static void aux_sub_on_instr(instruction *the_instr, void *);
99 static void fix_arrays_on_node(tree_node *the_node, void *);
100 static void fix_arrays_on_instr(instruction *the_instr);
101 static void fix_arrays_on_operand(operand the_operand);
102 static array_type *array_type_from_aref(in_array *the_aref);
103 static array_type *register_type_for_base_name(const char *base_name,
104 type_node *element_type,
105 base_symtab *the_symtab);
106 static array_type *array_type_for_base_name(const char *base_name,
107 type_node *base_type,
108 unsigned *num_dimensions);
109 static type_node *string_type_for_base_name(const char *base_name,
110 base_symtab *the_symtab);
111 static array_bound bound_from_aux(var_sym *the_var);
112 static void fix_addresses(instruction *the_instr, void *);
113 static void deallocate_operand(operand to_go);
114 static operand build_offset_operand(array_type *the_array_type,
115 int num_dimensions);
116 static const char *last_field(immed_list *field_immeds);
117 static char *guess_base_var_name(in_array *the_array);
118 static void linear_form(operand *op_a, operand *op_b, operand original,
119 var_sym *the_var);
120 static boolean is_zero(operand the_operand);
121 static void nullify_operand(operand *the_operand);
122 static boolean is_subtracted(operand the_operand, var_sym *the_variable,
123 boolean negated);
124 static operand remove_subtracted_variable(operand the_operand,
125 var_sym *the_variable,
126 boolean negated);
127 static boolean operand_is_var(operand the_operand, var_sym *the_variable);
128 static void mark_params_call_by_ref(tree_proc *the_tree_proc);
129 static void fix_symtabs(base_symtab *the_symtab);
130 static void fix_symtab(base_symtab *the_symtab);
131 static boolean is_complex(type_node *the_type);
132 static type_node *complex_replacement(type_node *complex_type);
133 static void replace_complex_in_type(type_node *the_type);
134 static void fix_complex_refs(tree_proc *the_proc);
135 static void fix_complex_on_tree_node(tree_node *the_node, void *);
136 static void fix_complex_on_instr(instruction *the_instr, void *);
137 static void drop_last_field_name(instruction *the_instr);
138 static void fix_complex_store(in_rrr *the_store);
139 static operand make_re_evalable(operand the_op, tree_node *place);
140 static operand simplify_address(operand old_address, type_node *new_type,
141 const char *name);
142 static boolean is_simple_var_addr(operand the_op, var_sym **the_var);
143 static const char *new_field_name(const char *desired_name,
144 struct_type *the_struct);
145 static int biggest_char_array_at_offset(struct_type *the_struct, int offset);
146 static type_node *original_op_type(operand the_op);
147 static void mark_common_blocks(base_symtab *the_symtab);
148 static void fix_defs(suif_object *the_object);
149
150 /*----------------------------------------------------------------------*
151 End Private Function Declarations
152 *----------------------------------------------------------------------*/
153 /*----------------------------------------------------------------------*
154 Begin Public Function Implementations
155 *----------------------------------------------------------------------*/
156
157 extern int main(int argc, char *argv[])
158 {
159 int remainder = INT_MAX;
160 max_int_str_len = 1;
161 while (remainder >= 10)
162 {
163 remainder /= 10;
164 ++max_int_str_len;
165 }
166 start_suif(argc, argv);
167
168 ANNOTE(k_fixfortran_needed_aux, "fixfortran needed aux",
169 FALSE);
170 ANNOTE(k_fixfortran_fixed_array_type, "fixfortran fixed array type",
171 FALSE);
172 k_fixfortran_original_type =
173 lexicon->enter("fixfortran original type")->sp;
174 ANNOTE(k_io_read, "io read", TRUE);
175 ANNOTE(k_io_write, "io write", TRUE);
176
177 if (argc < 2)
178 error_line(1, NULL, "no file specifications given");
179 else if (argc == 2)
180 error_line(1, NULL, "no output file specification given");
181 else if (argc > 3)
182 error_line(1, NULL, "too many file specifications given");
183
184 fileset->add_file(argv[1], argv[2]);
185 mark_intrinsics(fileset->globals());
186 fix_symtab(fileset->globals());
187
188 fileset->reset_iter();
189 while (TRUE)
190 {
191 file_set_entry *fse = fileset->next_file();
192 if (fse == NULL)
193 break;
194 fse->reset_proc_iter();
195 mark_constants(fse->symtab());
196 fix_symtab(fse->symtab());
197 fse->reset_proc_iter();
198 while (TRUE)
199 {
200 proc_sym *this_proc_sym = fse->next_proc();
201 if (this_proc_sym == NULL)
202 break;
203 this_proc_sym->read_proc(TRUE, FALSE);
204 do_proc(this_proc_sym->block());
205 this_proc_sym->write_proc(fse);
206 this_proc_sym->flush_proc();
207 }
208 mark_common_blocks(fse->symtab());
209 }
210
211 mark_common_blocks(fileset->globals());
212
213 fileset->reset_iter();
214 while (TRUE)
215 {
216 file_set_entry *fse = fileset->next_file();
217 if (fse == NULL)
218 break;
219 walk(fse->symtab(), &fix_defs);
220 }
221 walk(fileset->globals(), &fix_defs);
222
223 delete fileset;
224
225 if (errors)
226 return 1;
227 else
228 return 0;
229 }
230
231 /*
232 * This takes an operand of the form
233 *
234 * <expr>
235 *
236 * and turns it into the form
237 *
238 * &(<expr>[const])
239 *
240 * The result is the same memory address plus const times the size, but the
241 * type changes from a pointer to an array to a pointer to the element type
242 * of the array. If the original expression is an array reference itself
243 * and has no "fields" annotation or iteger offset, the constant array
244 * reference is tacked onto the end of the existing reference.
245 *
246 * Restrictions: The type of the original expression must be a pointer to
247 * an array with lower bound of zero (i.e. a C array).
248 */
249 extern in_array *add_const_aref(operand array_pointer, int constant)
250 {
251 assert(array_pointer.type()->unqual()->is_ptr());
252 ptr_type *the_ptr_type = (ptr_type *)(array_pointer.type()->unqual());
253 assert(the_ptr_type->ref_type()->unqual()->is_array());
254 array_type *the_array_type =
255 (array_type *)(the_ptr_type->ref_type()->unqual());
256
257 type_node *new_type = the_array_type->elem_type()->ptr_to();
258
259 if (array_pointer.is_expr())
260 {
261 instruction *the_instr = array_pointer.instr();
262 if ((the_instr->opcode() == io_array) &&
263 (the_instr->peek_annote(k_fields) == NULL))
264 {
265 in_array *the_array = (in_array *)the_instr;
266 if (the_array->offset() == 0)
267 {
268 int num_elems = the_array->elem_size() /
269 the_array_type->elem_type()->size();
270 unsigned num_dims = the_array->dims();
271 ++num_dims;
272 the_array->set_dims(num_dims);
273 the_array->set_index(num_dims - 1,
274 const_op(immed(constant), type_ptr_diff));
275 the_array->set_bound(num_dims - 1,
276 const_op(immed(num_elems),
277 type_ptr_diff));
278 the_array->set_elem_size(the_array_type->elem_type()->size());
279 operand offset_operand = the_array->offset_op();
280 if (!offset_operand.is_null())
281 {
282 offset_operand.remove();
283 the_array->set_offset_op(offset_operand * num_elems);
284 }
285 the_array->set_result_type(new_type);
286 return the_array;
287 }
288 }
289 }
290
291 in_array *new_array =
292 new in_array(new_type, operand(), array_pointer,
293 the_array_type->elem_type()->size(), 1, 0,
294 operand());
295 new_array->set_index(0, const_op(immed(constant), type_ptr_diff));
296 new_array->set_bound(0, operand());
297 return new_array;
298 }
299
300 /*----------------------------------------------------------------------*
301 End Public Function Implementations
302 *----------------------------------------------------------------------*/
303 /*----------------------------------------------------------------------*
304 Begin Private Function Implementations
305 *----------------------------------------------------------------------*/
306
307 static void mark_intrinsics(global_symtab *the_symtab)
308 {
309 static char *pure_intrinsic_names[] =
310 {
311 "sin",
312 "F_sin",
313 "cos",
314 "F_cos",
315 "tan",
316 "F_tan",
317 "asin",
318 "F_asin",
319 "acos",
320 "F_acos",
321 "atan2",
322 "F_atan2",
323 "atan",
324 "F_atan",
325 "sinh",
326 "cosh",
327 "tanh",
328 "log",
329 "F_log",
330 "sqrt",
331 "F_sqrt",
332 "exp",
333 "F_exp",
334 "r_lg10",
335 "d_lg10",
336 "i_sign",
337 "r_sign",
338 "d_sign",
339 "h_mod",
340 "i_mod",
341 "r_mod",
342 "d_mod",
343 "i_nint",
344 "i_dnnt",
345 "r_nint",
346 "d_nint",
347 "r_int",
348 "d_int",
349 "pow_ii",
350 "pow_ri",
351 "pow_di",
352 "pow_ci",
353 "pow_zi",
354 "pow_hh",
355 "pow_dd",
356 "pow_zz",
357 "c_div",
358 "z_div",
359 "s_copy",
360 "s_cmp",
361 "s_cat",
362 "r_imag",
363 "d_imag",
364 "r_dim",
365 "sc_abs",
366 "sz_abs",
367 NULL
368 };
369
370 static char *intrinsic_fortran_names[] =
371 {
372 "DSIN", /* sin */
373 "DSIN", /* F_sin */
374 "DCOS", /* cos */
375 "DCOS", /* F_cos */
376 "DTAN", /* tan */
377 "DTAN", /* F_tan */
378 "DASIN", /* asin */
379 "DASIN", /* F_asin */
380 "DACOS", /* acos */
381 "DACOS", /* F_acos */
382 "DATAN2", /* atan2 */
383 "DATAN2", /* F_atan2 */
384 "DATAN", /* atan */
385 "DATAN", /* F_atan */
386 "DSINH", /* sinh */
387 "DCOSH", /* cosh */
388 "DTANH", /* tanh */
389 "DLOG", /* log */
390 "DLOG", /* F_log */
391 "DSQRT", /* sqrt */
392 "DSQRT", /* F_sqrt */
393 "DEXP", /* exp */
394 "DEXP", /* F_exp */
395 "ALOG10", /* r_lg10 */
396 "DLOG10", /* d_lg10 */
397 "ISIGN", /* i_sign */
398 "SIGN", /* r_sign */
399 "DSIGN", /* d_sign */
400 NULL, /* h_mod */
401 "MOD", /* i_mod */
402 "AMOD", /* r_mod */
403 "DMOD", /* d_mod */
404 "NINT", /* i_nint */
405 "IDNINT", /* i_dnnt */
406 "ANINT", /* r_nint */
407 "DNINT", /* d_nint */
408 "AINT", /* r_int */
409 "DINT", /* d_int */
410 "**", /* pow_ii */
411 "**", /* pow_ri */
412 "**", /* pow_di */
413 "**", /* pow_ci */
414 "**", /* pow_zi */
415 "**", /* pow_hh */
416 "**", /* pow_dd */
417 "**", /* pow_zz */
418 NULL, /* c_div */
419 NULL, /* z_div */
420 NULL, /* s_copy */
421 NULL, /* s_cmp */
422 NULL, /* s_cat */
423 "AIMAG", /* r_imag */
424 NULL, /* d_imag */
425 "DIM", /* r_dim */
426 NULL, /* sc_abs */
427 NULL, /* sz_abs */
428 NULL
429 };
430
431 sym_node_list_iter sym_iter(the_symtab->symbols());
432 while (!sym_iter.is_empty())
433 {
434 sym_node *this_symbol = sym_iter.step();
435 if (this_symbol->is_proc())
436 {
437 char **follow = &(pure_intrinsic_names[0]);
438 unsigned long counter = 0;
439 while (*follow != NULL)
440 {
441 if (strcmp(this_symbol->name(), *follow) == 0)
442 {
443 this_symbol->append_annote(k_pure_function);
444 char *fortran_name = intrinsic_fortran_names[counter];
445 if (fortran_name != NULL)
446 {
447 if (strcmp(fortran_name, "**") == 0)
448 {
449 this_symbol->append_annote(k_fortran_power_op);
450 }
451 else
452 {
453 immed_list *data =
454 new immed_list(immed(fortran_name));
455 this_symbol->append_annote(k_fortran_intrinsic,
456 data);
457 }
458 }
459 break;
460 }
461 ++follow;
462 ++counter;
463 }
464 }
465 }
466 }
467
468 static void do_proc(tree_proc *the_tree_proc)
469 {
470 if (the_tree_proc->proc()->src_lang() == src_fortran)
471 {
472 error_line(0, the_tree_proc,
473 "function %s has already been converted to fortran",
474 the_tree_proc->proc()->name());
475 errors = TRUE;
476 return;
477 }
478
479 de_linearize(the_tree_proc);
480 fix_symtabs(the_tree_proc->proc_syms());
481 mark_params_call_by_ref(the_tree_proc);
482 fix_complex_refs(the_tree_proc);
483 mark_io_on_list(the_tree_proc->body());
484 limit_complex_temp_scopes(the_tree_proc->body());
485 walk(the_tree_proc, &fix_defs);
486
487 the_tree_proc->proc()->append_annote(k_no_recursion);
488 the_tree_proc->proc()->set_src_lang(src_fortran);
489 }
490
491 static void de_linearize(tree_proc *the_proc)
492 {
493 assert(the_proc != NULL);
494
495 if (the_proc->body() == NULL)
496 return;
497
498 aux_var_values = new alist;
499 array_types = new alist;
500
501 tree_node_list_iter body_iter(the_proc->body());
502 while (!body_iter.is_empty())
503 {
504 tree_node *this_node = body_iter.step();
505 assert(this_node != NULL);
506
507 if (this_node->is_instr())
508 {
509 tree_instr *this_tree_instr = (tree_instr *)this_node;
510 instruction *this_instr = this_tree_instr->instr();
511 assert(this_instr != NULL);
512 operand destination = this_instr->dst_op();
513 if (destination.is_symbol())
514 {
515 var_sym *this_var = destination.symbol();
516 assert(this_var != NULL);
517 if ((strstr(this_var->name(), "_offset") != NULL) ||
518 (strstr(this_var->name(), "_dim") != NULL) ||
519 (strstr(this_var->name(), "_lb") != NULL) ||
520 (strstr(this_var->name(), "_ub") != NULL) ||
521 (strstr(this_var->name(), "_strlen") != NULL))
522 {
523 if (aux_var_values->exists(this_var))
524 {
525 /*
526 * It can happen that one of these array linearization
527 * auxiliary variables is initialized more than once:
528 * f2c writes a ``prolog'' that initializes these
529 * things and it writes one prolog for every entry
530 * point. It would only need to do the part of the
531 * prolog concerning parameters for each entry point,
532 * but it doesn't, it simply produces an entire prolog
533 * for each. That means auxiliaries for things common
534 * to all entry points (most locals) are repeated.
535 * This still produces correct code, it's just
536 * redundant. Since f2c writes all the prologs before
537 * the switch to branch to the label for the particular
538 * entry point, all the prologs are executed for every
539 * entry point. Hence all the auxiliary variables that
540 * are written multiple times must be given the same
541 * values or else it would be wrong for some entry
542 * point. So when we can just ignore the redundant
543 * assignment at this point.
544 */
545 continue;
546 }
547
548 aux_var_values->enter(this_var, this_tree_instr);
549 }
550 }
551 }
552 }
553
554 alist vars_to_delete;
555
556 tree_node_list_iter base_body_iter(the_proc->body());
557 while (!base_body_iter.is_empty())
558 {
559 tree_node *this_node = base_body_iter.step();
560 assert(this_node != NULL);
561
562 if (this_node->is_instr())
563 {
564 tree_instr *this_tree_instr = (tree_instr *)this_node;
565 instruction *this_instr = this_tree_instr->instr();
566 assert(this_instr != NULL);
567 operand destination = this_instr->dst_op();
568 if (destination.is_symbol())
569 {
570 var_sym *this_var = destination.symbol();
571 assert(this_var != NULL);
572 boolean is_a_base = FALSE;
573 if (strstr(this_var->name(), "_base") != NULL)
574 {
575 fix_array_type_for_base_expr(this_instr);
576 is_a_base = TRUE;
577 }
578 else if (strstr(this_var->name(), "_strbase") != NULL)
579 {
580 fix_array_type_for_str_base_expr(this_instr);
581 is_a_base = TRUE;
582 }
583
584 if (is_a_base)
585 {
586 tree_node_list_e *this_elem = this_tree_instr->list_e();
587 the_proc->body()->remove(this_elem);
588 delete this_elem;
589 delete this_tree_instr;
590
591 if (!vars_to_delete.exists(this_var))
592 vars_to_delete.enter(this_var, this_var);
593 }
594 }
595 }
596 }
597
598 the_proc->map(&fix_arrays_on_node, NULL);
599
600 alist_iter value_iter(aux_var_values);
601 while (!value_iter.is_empty())
602 {
603 alist_e *this_alist_e = value_iter.step();
604 assert(this_alist_e != NULL);
605 aux_var_values->remove(this_alist_e);
606 delete this_alist_e;
607 }
608 delete aux_var_values;
609 aux_var_values = NULL;
610
611 tree_node_list_iter del_body_iter(the_proc->body());
612 while (!del_body_iter.is_empty())
613 {
614 tree_node *this_node = del_body_iter.step();
615 assert(this_node != NULL);
616
617 if (this_node->is_instr())
618 {
619 tree_instr *this_tree_instr = (tree_instr *)this_node;
620 instruction *this_instr = this_tree_instr->instr();
621 assert(this_instr != NULL);
622 operand destination = this_instr->dst_op();
623 if (destination.is_symbol())
624 {
625 var_sym *this_var = destination.symbol();
626 assert(this_var != NULL);
627 if ((strstr(this_var->name(), "_offset") != NULL) ||
628 (strstr(this_var->name(), "_dim") != NULL) ||
629 (strstr(this_var->name(), "_lb") != NULL) ||
630 (strstr(this_var->name(), "_ub") != NULL) ||
631 (strstr(this_var->name(), "_strlen") != NULL))
632 {
633 if (this_var->peek_annote(k_fixfortran_needed_aux) == NULL)
634 {
635 tree_node_list_e *this_elem =
636 this_tree_instr->list_e();
637 the_proc->body()->remove(this_elem);
638 delete this_elem;
639 delete this_tree_instr;
640
641 if (!vars_to_delete.exists(this_var))
642 vars_to_delete.enter(this_var, this_var);
643 }
644 }
645 }
646 }
647 }
648
649 alist_iter to_delete_iter(&vars_to_delete);
650 while (!to_delete_iter.is_empty())
651 {
652 alist_e *this_alist_e = to_delete_iter.step();
653 assert(this_alist_e != NULL);
654
655 var_sym *this_var = (var_sym *)this_alist_e->key;
656 assert(this_var != NULL);
657
658 this_var->parent()->remove_sym(this_var);
659 delete this_var;
660
661 vars_to_delete.remove(this_alist_e);
662 delete this_alist_e;
663 }
664
665 alist_iter type_iter(array_types);
666 while (!type_iter.is_empty())
667 {
668 alist_e *this_alist_e = type_iter.step();
669 assert(this_alist_e != NULL);
670 array_types->remove(this_alist_e);
671 delete this_alist_e;
672 }
673 delete array_types;
674 }
675
676 /*
677 * This function takes as an argument an instruction of the form
678 *
679 * <str>_base = (int) &(<base_expr>[0])
680 *
681 * where <str> is a string (the name of the variable in Fortran) and
682 * <base_expr> is the C expression for the base of the array. This
683 * function uses <str> to find the auxiliary variables for the array
684 * type and sets the type of <base_expr> to that type if <base_expr>'s
685 * type comes from something like a variable or structure member that
686 * can be changed so that other occurances of <base_expr> will have
687 * that type.
688 *
689 * This has the effect of restoring the types of arrays that are local
690 * variables, parameters, or elements of common blocks.
691 */
692 void fix_array_type_for_base_expr(instruction *the_instr)
693 {
694 assert(the_instr != NULL);
695
696 assert(the_instr->dst_op().is_symbol());
697 var_sym *base_aux_var_sym = the_instr->dst_op().symbol();
698 const char *base_aux_var_name = base_aux_var_sym->name();
699
700 char *suffix = strstr(base_aux_var_name, "_base");
701 assert(suffix != NULL);
702
703 if (strcmp(suffix, "_base") != 0)
704 {
705 error_line(0, the_instr,
706 "variable name contains ``_base'' but not as a suffix;");
707 error_line(0, the_instr,
708 "reconstruction of array types from auxiliary variables "
709 "failed");
710 errors = TRUE;
711 return;
712 }
713
714 char *old_storage = new char[suffix - base_aux_var_name + 1];
715 strncpy(old_storage, base_aux_var_name, suffix - base_aux_var_name);
716 old_storage[suffix - base_aux_var_name] = 0;
717 const char *aux_base_name = old_storage;
718 aux_base_name = lexicon->enter(aux_base_name)->sp;
719 delete[] old_storage;
720
721 operand aref_base_op(the_instr);
722 while (aref_base_op.is_instr() &&
723 ((aref_base_op.instr()->opcode() == io_cvt) ||
724 (aref_base_op.instr()->opcode() == io_cpy)))
725 {
726 in_rrr *the_rrr = (in_rrr *)(aref_base_op.instr());
727 aref_base_op = the_rrr->src_op();
728 }
729
730 if (aref_base_op.is_instr() &&
731 (aref_base_op.instr()->opcode() == io_array))
732 {
733 in_array *the_aref = (in_array *)(aref_base_op.instr());
734 aref_base_op = the_aref->base_op();
735 }
736
737 type_node *base_type = aref_base_op.type()->unqual();
738 if (!base_type->is_ptr())
739 {
740 error_line(0, the_instr->parent(),
741 "bad format for `%s_base' auxiliary expression;",
742 aux_base_name);
743 error_line(0, the_instr->parent(),
744 "reconstruction of array types from auxiliary "
745 "variables failed");
746 errors = TRUE;
747 return;
748 }
749 ptr_type *the_pointer = (ptr_type *)base_type;
750
751 type_node *element_type = the_pointer->ref_type()->unqual();
752
753 boolean is_param = FALSE;
754 var_sym *param_var = NULL;
755
756 while (aref_base_op.is_instr() &&
757 (aref_base_op.instr()->opcode() == io_cvt))
758 {
759 in_rrr *the_cvt = (in_rrr *)(aref_base_op.instr());
760 aref_base_op = the_cvt->src_op();
761 }
762
763 if (aref_base_op.is_symbol())
764 {
765 var_sym *the_var = aref_base_op.symbol();
766 if (the_var->is_param())
767 {
768 is_param = TRUE;
769 param_var = the_var;
770 }
771 }
772
773 if (aref_base_op.is_instr() && (aref_base_op.instr()->opcode() == io_ldc))
774 {
775 in_ldc *the_ldc = (in_ldc *)(aref_base_op.instr());
776 immed value = the_ldc->value();
777 if (value.is_symbol() && value.symbol()->is_var() &&
778 (value.offset() == 0))
779 {
780 var_sym *the_var = (var_sym *)(value.symbol());
781 if (the_var->is_param())
782 {
783 is_param = TRUE;
784 param_var = the_var;
785 assert(element_type->is_ptr());
786 ptr_type *element_ptr = (ptr_type *)element_type;
787 element_type = element_ptr->ref_type()->unqual();
788 }
789 }
790 }
791
792 if (element_type->is_array())
793 {
794 array_type *the_array_type = (array_type *)element_type;
795 element_type = the_array_type->elem_type()->unqual();
796 }
797
798 if ((element_type->op() == TYPE_INT) &&
799 (element_type->size() == target.size[C_char]))
800 {
801 element_type = string_type_for_base_name(aux_base_name,
802 base_aux_var_sym->parent());
803 }
804
805 type_node *new_type =
806 register_type_for_base_name(aux_base_name, element_type,
807 base_aux_var_sym->parent());
808
809 if (is_param)
810 {
811 param_var->set_type(new_type->ptr_to());
812 return;
813 }
814
815 operand new_op =
816 simplify_address(aref_base_op.clone(), new_type, aux_base_name);
817 if (new_op.is_expr())
818 delete new_op.instr();
819 }
820
821 /*
822 * This function takes as an argument an instruction of the form
823 *
824 * <str>_strbase = (int) <base_expr>
825 *
826 * where <str> is a string (the name of the variable in Fortran) and
827 * <base_expr> is the C expression for the location of the string or
828 * array of strings. This function first checks for a <str>_base
829 * auxiliary variable, and if it finds one, it returns without doing
830 * anything because this means it is really an array of strings and it
831 * will be handled by the array handling code in
832 * fix_array_type_for_base_expr(). Otherwise, it uses <str> to find
833 * the auxiliary variable for the length and sets the type of
834 * *<base_expr> to a character array from one to that length if
835 * *<base_expr>'s type comes from something like a variable or
836 * structure member that can be changed so that other occurances of
837 * *<base_expr> will have that type.
838 *
839 * This has the effect of restoring the types of strings that are
840 * local variables, parameters, or elements of common blocks.
841 */
842 void fix_array_type_for_str_base_expr(instruction *the_instr)
843 {
844 assert(the_instr != NULL);
845
846 assert(the_instr->dst_op().is_symbol());
847 var_sym *base_aux_var_sym = the_instr->dst_op().symbol();
848 const char *base_aux_var_name = base_aux_var_sym->name();
849
850 char *suffix = strstr(base_aux_var_name, "_strbase");
851 assert(suffix != NULL);
852
853 if (strcmp(suffix, "_strbase") != 0)
854 {
855 error_line(0, the_instr,
856 "variable name contains ``_strbase'' but not as a suffix;");
857 error_line(0, the_instr,
858 "reconstruction of string types from auxiliary variables "
859 "failed");
860 errors = TRUE;
861 return;
862 }
863
864 char *old_storage = new char[suffix - base_aux_var_name + 1];
865 strncpy(old_storage, base_aux_var_name, suffix - base_aux_var_name);
866 old_storage[suffix - base_aux_var_name] = 0;
867 const char *aux_base_name = old_storage;
868 aux_base_name = lexicon->enter(aux_base_name)->sp;
869 delete[] old_storage;
870
871 char *aux_array_base_name = new char[strlen(aux_base_name) + 8];
872 strcpy(aux_array_base_name, aux_base_name);
873 strcat(aux_array_base_name, "_base");
874 var_sym *aux_array_base_var =
875 base_aux_var_sym->parent()->lookup_var(aux_array_base_name);
876 delete[] aux_array_base_name;
877
878 if (aux_array_base_var != NULL)
879 return;
880
881 operand aref_base_op(the_instr);
882 while (aref_base_op.is_instr() &&
883 ((aref_base_op.instr()->opcode() == io_cvt) ||
884 (aref_base_op.instr()->opcode() == io_cpy)))
885 {
886 in_rrr *the_rrr = (in_rrr *)(aref_base_op.instr());
887 aref_base_op = the_rrr->src_op();
888 }
889
890 if (aref_base_op.is_instr() &&
891 (aref_base_op.instr()->opcode() == io_array))
892 {
893 in_array *the_aref = (in_array *)(aref_base_op.instr());
894 aref_base_op = the_aref->base_op();
895 }
896
897 boolean is_param = FALSE;
898 var_sym *param_var = NULL;
899
900 while (aref_base_op.is_instr() &&
901 (aref_base_op.instr()->opcode() == io_cvt))
902 {
903 in_rrr *the_cvt = (in_rrr *)(aref_base_op.instr());
904 aref_base_op = the_cvt->src_op();
905 }
906
907 if (aref_base_op.is_symbol())
908 {
909 var_sym *the_var = aref_base_op.symbol();
910 if (the_var->is_param())
911 {
912 is_param = TRUE;
913 param_var = the_var;
914 }
915 }
916
917 if (aref_base_op.is_instr() && (aref_base_op.instr()->opcode() == io_ldc))
918 {
919 in_ldc *the_ldc = (in_ldc *)(aref_base_op.instr());
920 immed value = the_ldc->value();
921 if (value.is_symbol() && value.symbol()->is_var() &&
922 (value.offset() == 0))
923 {
924 var_sym *the_var = (var_sym *)(value.symbol());
925 if (the_var->is_param())
926 {
927 is_param = TRUE;
928 param_var = the_var;
929 }
930 }
931 }
932
933 type_node *new_type =
934 string_type_for_base_name(aux_base_name,
935 base_aux_var_sym->parent());
936
937 if (is_param)
938 {
939 param_var->append_annote(k_fixfortran_original_type,
940 param_var->type());
941 param_var->set_type(new_type->ptr_to());
942 return;
943 }
944
945 operand new_op =
946 simplify_address(aref_base_op.clone(), new_type, aux_base_name);
947 if (new_op.is_expr())
948 delete new_op.instr();
949 }
950
951 static void aux_sub_on_instr(instruction *the_instr, void *)
952 {
953 assert(the_instr != NULL);
954
955 unsigned num_srcs = the_instr->num_srcs();
956 for (unsigned src_num = 0; src_num < num_srcs; ++src_num)
957 {
958 operand this_operand = the_instr->src_op(src_num);
959 if (this_operand.is_symbol())
960 {
961 var_sym *this_var = this_operand.symbol();
962 alist_e *the_alist_e = aux_var_values->search(this_var);
963 if (the_alist_e != NULL)
964 {
965 tree_instr *old_tree_instr = (tree_instr *)(the_alist_e->info);
966 instruction *old_instr = old_tree_instr->instr();
967 assert(old_instr != NULL);
968
969 instruction *new_instr =
970 old_instr->clone(the_instr->parent()->scope());
971 new_instr->set_dst(operand());
972 the_instr->set_src_op(src_num, operand(new_instr));
973 }
974 }
975 }
976
977 /*
978 * sf2c sometimes passes the location of one of these, such as &x_dim1, to
979 * an I/O routine. So if it's location is needed, we'd better not delete
980 * it.
981 */
982 if (the_instr->opcode() == io_ldc)
983 {
984 in_ldc *the_ldc = (in_ldc *)the_instr;
985 immed value = the_ldc->value();
986 if (value.is_symbol())
987 {
988 sym_node *the_symbol = value.symbol();
989 if (aux_var_values->search(the_symbol) != NULL)
990 {
991 the_symbol->append_annote(k_fixfortran_needed_aux,
992 new immed_list);
993 }
994 }
995 }
996 }
997
998 static void fix_arrays_on_node(tree_node *the_node, void *)
999 {
1000 assert(the_node != NULL);
1001
1002 if (!the_node->is_instr())
1003 return;
1004
1005 tree_instr *the_tree_instr = (tree_instr *)the_node;
1006 fix_arrays_on_instr(the_tree_instr->instr());
1007 the_tree_instr->instr_map(&fix_addresses, NULL, FALSE);
1008 the_tree_instr->instr_map(&inline_intrinsics_on_instr, NULL, FALSE);
1009 the_tree_instr->instr_map(&aux_sub_on_instr, NULL);
1010 }
1011
1012 static void fix_arrays_on_instr(instruction *the_instr)
1013 {
1014 assert(the_instr != NULL);
1015
1016 unsigned num_srcs = the_instr->num_srcs();
1017 for (unsigned src_num = 0; src_num < num_srcs; ++src_num)
1018 fix_arrays_on_operand(the_instr->src_op(src_num));
1019
1020 if (the_instr->opcode() != io_array)
1021 return;
1022
1023 in_array *old_array = (in_array *)the_instr;
1024 if (old_array->dims() != 1)
1025 {
1026 error_line(0, the_instr->parent(),
1027 "array reference with %d dimensions found",
1028 old_array->dims());
1029 errors = TRUE;
1030 return;
1031 }
1032
1033 char *base_var_name = guess_base_var_name(old_array);
1034 if (base_var_name == NULL)
1035 {
1036 /*
1037 * If we can't find the base name, then this is not in the form of
1038 * an array reference translated from Fortran by sf2c. So assume
1039 * that it is a C array reference to an sf2c generated array. Such
1040 * C arrays are generated to translate complicated Fortran internals
1041 * such as string operations and I/O.
1042 */
1043
1044 operand base_operand = old_array->base_op();
1045 base_operand.remove();
1046 assert(base_operand.type()->is_ptr());
1047 ptr_type *base_ptr = (ptr_type *)(base_operand.type());
1048 base_operand =
1049 simplify_address(base_operand, base_ptr->ref_type()->unqual(),
1050 NULL);
1051 old_array->set_base_op(base_operand);
1052
1053 return;
1054 }
1055
1056 type_node *base_type = array_type_from_aref(old_array);
1057 if (base_type == NULL)
1058 return;
1059
1060 if (base_type->is_array())
1061 {
1062 array_type *the_array = (array_type *)base_type;
1063 base_type = the_array->elem_type();
1064 }
1065
1066 base_symtab *the_symtab = the_instr->owner()->scope();
1067
1068 unsigned num_dimensions;
1069 array_type *new_type =
1070 array_type_for_base_name(base_var_name, base_type,
1071 &num_dimensions);
1072
1073 char *auxiliary_name =
1074 new char[strlen(base_var_name) + max_int_str_len + 5];
1075 strcpy(auxiliary_name, base_var_name);
1076 strcat(auxiliary_name, "_dim");
1077 char *number_place = auxiliary_name + strlen(base_var_name) + 4;
1078
1079 operand offset_operand = old_array->offset_op();
1080 offset_operand.remove();
1081 if (!is_zero(offset_operand))
1082 {
1083 error_line(0, the_instr->parent(),
1084 "Fortran array already contains a non-zero offset");
1085 errors = TRUE;
1086 }
1087 deallocate_operand(offset_operand);
1088
1089 char *offset_var_name = new char[strlen(base_var_name) + 8];
1090 strcpy(offset_var_name, base_var_name);
1091 strcat(offset_var_name, "_offset");
1092 var_sym *offset_var = the_symtab->lookup_var(offset_var_name);
1093
1094 if (offset_var == NULL)
1095 {
1096 error_line(0, the_instr->parent(),
1097 "unable to find offset variable %s", offset_var_name);
1098 errors = TRUE;
1099 }
1100 delete[] offset_var_name;
1101
1102 delete[] base_var_name;
1103
1104 operand old_bound = old_array->bound(0);
1105 old_bound.remove();
1106 deallocate_operand(old_bound);
1107
1108 operand base_operand = old_array->base_op();
1109 base_operand.remove();
1110
1111 base_operand = simplify_address(base_operand, new_type, NULL);
1112
1113 operand remaining_index = old_array->index(0);
1114 remaining_index.remove();
1115
1116 offset_operand = build_offset_operand(new_type, num_dimensions);
1117
1118 in_array *new_array = new in_array(old_array->result_type(), operand(),
1119 base_operand, old_array->elem_size(),
1120 num_dimensions, old_array->offset(),
1121 operand());
1122 new_array->annotes()->append(old_array->annotes());
1123
1124 while (remaining_index.is_instr() &&
1125 (remaining_index.instr()->opcode() == io_cvt))
1126 {
1127 in_rrr *the_cvt = (in_rrr *)(remaining_index.instr());
1128 remaining_index = the_cvt->src_op();
1129 }
1130
1131 /* skip multiplication done for character strings */
1132 if (remaining_index.is_instr() &&
1133 (remaining_index.instr()->opcode() == io_mul))
1134 {
1135 in_rrr *the_div = (in_rrr *)(remaining_index.instr());
1136 remaining_index = the_div->src1_op();
1137 }
1138
1139 if (!is_subtracted(remaining_index, offset_var, FALSE))
1140 {
1141 error_line(0, the_instr->parent(),
1142 "offset for Fortran array not subtracted");
1143 errors = TRUE;
1144 }
1145 remaining_index = remove_subtracted_variable(remaining_index, offset_var,
1146 FALSE);
1147 unsigned dimension_num;
1148 for (dimension_num = 0; dimension_num + 1 < num_dimensions;
1149 ++dimension_num)
1150 {
1151 sprintf(number_place, "%u", dimension_num + 1);
1152 var_sym *bound_var = the_symtab->lookup_var(auxiliary_name);
1153
1154 if (bound_var == NULL)
1155 {
1156 error_line(0, the_instr->parent(),
1157 "unable to find bound variable %s", auxiliary_name);
1158 errors = TRUE;
1159 }
1160
1161 operand op_a, op_b;
1162 linear_form(&op_a, &op_b, remaining_index, bound_var);
1163 remaining_index = op_b;
1164 new_array->set_index(num_dimensions - (dimension_num + 1), op_a);
1165 }
1166
1167 new_array->set_index(0, remaining_index);
1168
1169 delete[] auxiliary_name;
1170
1171 type_node *follow_type = new_type;
1172 dimension_num = 0;
1173 while (dimension_num < num_dimensions)
1174 {
1175 assert(follow_type != NULL);
1176 assert(follow_type->is_array());
1177 array_type *follow_array = (array_type *)follow_type;
1178
1179 array_bound upper_bound = follow_array->upper_bound();
1180 array_bound lower_bound = follow_array->lower_bound();
1181 operand new_bound;
1182 if (upper_bound.is_unknown() || lower_bound.is_unknown())
1183 {
1184 new_bound = operand();
1185 }
1186 else
1187 {
1188 new_bound = (operand_from_array_bound(upper_bound) -
1189 operand_from_array_bound(lower_bound));
1190 new_bound = (new_bound + const_op(immed(1), new_bound.type()));
1191 }
1192 new_array->set_bound(dimension_num, new_bound);
1193
1194 follow_type = follow_array->elem_type()->unqual();
1195 ++dimension_num;
1196 }
1197
1198 /* handle the case of arrays of character strings */
1199 if (follow_type->is_array())
1200 {
1201 array_type *string_array = (array_type *)follow_type;
1202 if (string_array->elem_type()->unqual()->is_same(type_char))
1203 {
1204 new_array->set_dims(num_dimensions + 1);
1205 new_array->set_elem_size(type_char->size());
1206
1207 operand upper_op =
1208 operand_from_array_bound(string_array->upper_bound());
1209 operand lower_op =
1210 operand_from_array_bound(string_array->lower_bound());
1211 operand difference = ((upper_op - lower_op.clone()) + 1);
1212
1213 offset_operand *= difference.clone();
1214 offset_operand += lower_op.clone();
1215
1216 new_array->set_index(num_dimensions, lower_op);
1217 new_array->set_bound(num_dimensions, difference);
1218 }
1219 }
1220
1221 new_array->set_offset_op(offset_operand);
1222
1223 replace_instruction(old_array, new_array);
1224 delete old_array;
1225 }
1226
1227 static void fix_arrays_on_operand(operand the_operand)
1228 {
1229 if (!the_operand.is_expr())
1230 return;
1231
1232 fix_arrays_on_instr(the_operand.instr());
1233 }
1234
1235 static array_type *array_type_from_aref(in_array *the_aref)
1236 {
1237 type_node *base_type = the_aref->base_op().type()->unqual();
1238 if (base_type->is_ptr())
1239 {
1240 ptr_type *the_pointer = (ptr_type *)base_type;
1241 base_type = the_pointer->ref_type()->unqual();
1242 if (!base_type->is_array())
1243 {
1244 error_line(0, the_aref->parent(),
1245 "base of array reference instruction is not a pointer"
1246 " to an array");
1247 errors = TRUE;
1248 return NULL;
1249 }
1250 return (array_type *)base_type;
1251 }
1252 else
1253 {
1254 error_line(0, the_aref->parent(),
1255 "base of array reference instruction is not a pointer");
1256 errors = TRUE;
1257 return NULL;
1258 }
1259 }
1260
1261 static array_type *register_type_for_base_name(const char *base_name,
1262 type_node *element_type,
1263 base_symtab *the_symtab)
1264 {
1265 assert(base_name != NULL);
1266 assert(element_type != NULL);
1267
1268 alist_iter type_iter(array_types);
1269 while (!type_iter.is_empty())
1270 {
1271 alist_e *this_alist_e = type_iter.step();
1272 assert(this_alist_e != NULL);
1273 if (strcmp((char *)(this_alist_e->key), base_name) == 0)
1274 {
1275 /*
1276 * This happens whenever there are multiple entry points
1277 * for a function -- sf2c repeats all the declarations
1278 * once for each entry point.
1279 */
1280 unsigned dummy;
1281 return array_type_for_base_name(base_name, element_type, &dummy);
1282 }
1283 }
1284
1285 base_symtab *new_symtab = element_type->parent();
1286
1287 char *aux_lb_name = new char[strlen(base_name) + max_int_str_len + 4];
1288 strcpy(aux_lb_name, base_name);
1289 strcat(aux_lb_name, "_lb");
1290 char *lb_num_place = aux_lb_name + strlen(base_name) + 3;
1291
1292 char *aux_ub_name = new char[strlen(base_name) + max_int_str_len + 4];
1293 strcpy(aux_ub_name, base_name);
1294 strcat(aux_ub_name, "_ub");
1295 char *ub_num_place = aux_ub_name + strlen(base_name) + 3;
1296
1297 type_node *result = element_type;
1298 int dim_count = 0;
1299 while (TRUE)
1300 {
1301 sprintf(lb_num_place, "%d", dim_count + 1);
1302 var_sym *lb_var = the_symtab->lookup_var(aux_lb_name);
1303 if (lb_var == NULL)
1304 break;
1305
1306 ++dim_count;
1307
1308 array_type *new_type = new array_type(result);
1309 result = new_type;
1310
1311 array_bound new_lower = bound_from_aux(lb_var);
1312 new_type->set_lower_bound(new_lower);
1313 if (new_lower.is_variable())
1314 {
1315 new_symtab = joint_symtab(new_symtab,
1316 new_lower.variable()->parent());
1317 }
1318
1319 sprintf(ub_num_place, "%d", dim_count);
1320 var_sym *ub_var = the_symtab->lookup_var(aux_ub_name);
1321 if (ub_var == NULL)
1322 {
1323 new_type->set_upper_bound(array_bound());
1324 break;
1325 }
1326
1327 array_bound new_upper = bound_from_aux(ub_var);
1328 new_type->set_upper_bound(new_upper);
1329 if (new_upper.is_variable())
1330 {
1331 new_symtab = joint_symtab(new_symtab,
1332 new_upper.variable()->parent());
1333 }
1334 }
1335
1336 if (dim_count == 0)
1337 {
1338 error_line(0, NULL, "cannot find dimension variable %s", aux_lb_name);
1339 errors = TRUE;
1340 result = new array_type(element_type);
1341 }
1342
1343 delete[] aux_lb_name;
1344 delete[] aux_ub_name;
1345
1346 assert(new_symtab != NULL);
1347 array_type *installed_result =
1348 (array_type *)(new_symtab->install_type(result));
1349 array_types->enter(lexicon->enter(base_name)->sp, installed_result);
1350 return installed_result;
1351 }
1352
1353 static array_type *array_type_for_base_name(const char *base_name,
1354 type_node *base_type,
1355 unsigned *num_dimensions)
1356 {
1357 assert(base_name != NULL);
1358 assert(base_type != NULL);
1359 assert(num_dimensions != NULL);
1360
1361 alist_iter type_iter(array_types);
1362 while (!type_iter.is_empty())
1363 {
1364 alist_e *this_alist_e = type_iter.step();
1365 assert(this_alist_e != NULL);
1366 if (strcmp((char *)(this_alist_e->key), base_name) == 0)
1367 {
1368 array_type *result = (array_type *)(this_alist_e->info);
1369 int dim_count = 0;
1370 type_node *follow_type = result;
1371 while (!follow_type->is_same(base_type))
1372 {
1373 ++dim_count;
1374 assert(follow_type != NULL);
1375 if (!follow_type->is_array())
1376 {
1377 error_line(0, NULL,
1378 "array with base name \"%s\" used with "
1379 "conflicting element types", base_name);
1380 errors = TRUE;
1381 break;
1382 }
1383 array_type *follow_array = (array_type *)follow_type;
1384 follow_type = follow_array->elem_type();
1385 }
1386 if (base_type->unqual()->is_same(type_char))
1387 --dim_count;
1388 *num_dimensions = dim_count;
1389 return result;
1390 }
1391 }
1392
1393 error_line(0, NULL, "cannot find declaration statement for array `%s'",
1394 base_name);
1395 errors = TRUE;
1396
1397 *num_dimensions = 1;
1398 array_type *result = new array_type(base_type);
1399
1400 return (array_type *)(base_type->parent()->install_type(result));
1401 }
1402
1403 static type_node *string_type_for_base_name(const char *base_name,
1404 base_symtab *the_symtab)
1405 {
1406 char *aux_name = new char[strlen(base_name) + 8];
1407 strcpy(aux_name, base_name);
1408 strcat(aux_name, "_strlen");
1409 var_sym *aux_var = the_symtab->lookup_var(aux_name);
1410 delete[] aux_name;
1411
1412 if (aux_var == NULL)
1413 return type_char;
1414
1415 array_bound new_upper = bound_from_aux(aux_var);
1416 type_node *result =
1417 new array_type(type_char, array_bound(1), new_upper);
1418
1419 base_symtab *result_symtab;
1420 if (new_upper.is_variable())
1421 result_symtab = new_upper.variable()->parent();
1422 else
1423 result_symtab = fileset->globals();
1424 return result_symtab->install_type(result);
1425 }
1426
1427 static array_bound bound_from_aux(var_sym *the_var)
1428 {
1429 alist_e *the_alist_e = aux_var_values->search(the_var);
1430 if (the_alist_e == NULL)
1431 {
1432 error_line(0, NULL, "cannot find value of auxiliary variable %s",
1433 the_var->name());
1434 errors = TRUE;
1435 return array_bound();
1436 }
1437
1438 tree_instr *the_tree_instr = (tree_instr *)(the_alist_e->info);
1439 instruction *the_instr = the_tree_instr->instr();
1440 assert(the_instr != NULL);
1441
1442 array_bound result;
1443 immed value;
1444 eval_status return_code = evaluate_const_instr(the_instr, &value);
1445 if ((return_code == EVAL_OK) && value.is_integer())
1446 result = array_bound(value.integer());
1447
1448 if (result.is_unknown())
1449 {
1450 the_var->append_annote(k_fixfortran_needed_aux, new immed_list);
1451 result = array_bound(the_var);
1452 }
1453
1454 return result;
1455 }
1456
1457 static void fix_addresses(instruction *the_instr, void *)
1458 {
1459 unsigned first_src, last_src;
1460 boolean is_fio = FALSE;
1461 boolean is_memop = FALSE;
1462 switch (the_instr->opcode())
1463 {
1464 case io_lod:
1465 first_src = 0;
1466 last_src = 0;
1467 is_memop = TRUE;
1468 break;
1469 case io_str:
1470 case io_memcpy:
1471 first_src = 0;
1472 last_src = 1;
1473 is_memop = TRUE;
1474 break;
1475 case io_cal:
1476 {
1477 first_src = 1;
1478 last_src = the_instr->num_srcs() - 1;
1479 proc_sym *call_sym = proc_for_call((in_cal *)the_instr);
1480 if ((call_sym != NULL) &&
1481 ((strcmp(call_sym->name(), "do_fio") == 0) ||
1482 (strcmp(call_sym->name(), "do_lio") == 0) ||
1483 (strcmp(call_sym->name(), "do_uio") == 0)))
1484 {
1485 is_fio = TRUE;
1486 }
1487 break;
1488 }
1489 default:
1490 return;
1491 }
1492
1493 for (unsigned src_num = first_src; src_num <= last_src; ++src_num)
1494 {
1495 operand this_src = the_instr->src_op(src_num);
1496 if (!this_src.type()->unqual()->is_ptr())
1497 continue;
1498
1499 type_node *original_type = original_op_type(this_src);
1500 ptr_type *src_ptr = (ptr_type *)(this_src.type()->unqual());
1501 in_rrr *old_cvt = NULL;
1502 if (is_fio && this_src.is_expr() &&
1503 (this_src.instr()->opcode() == io_cvt) &&
1504 (src_ptr->ref_type()->op() == TYPE_INT) &&
1505 (src_ptr->ref_type()->size() == target.size[C_char]))
1506 {
1507 old_cvt = (in_rrr *)(this_src.instr());
1508 this_src = old_cvt->src_op();
1509 src_ptr = (ptr_type *)(this_src.type()->unqual());
1510 }
1511 this_src.remove();
1512 this_src = simplify_address(this_src, src_ptr->ref_type(), NULL);
1513 if (is_memop && (this_src.type() != src_ptr))
1514 this_src = fold_real_1op_rrr(io_cvt, original_type, this_src);
1515 if (old_cvt != NULL)
1516 old_cvt->set_src(this_src);
1517 else
1518 the_instr->set_src_op(src_num, this_src);
1519 }
1520
1521 switch (the_instr->opcode())
1522 {
1523 case io_lod:
1524 {
1525 in_rrr *the_load = (in_rrr *)the_instr;
1526 var_sym *loaded_var;
1527 boolean is_var =
1528 is_simple_var_addr(the_load->src_addr_op(), &loaded_var);
1529 if (is_var)
1530 {
1531 if (the_load->dst_op().is_instr())
1532 {
1533 instruction *parent_instr = the_load->dst_op().instr();
1534 unsigned num_srcs = parent_instr->num_srcs();
1535 unsigned src_num;
1536 for (src_num = 0; src_num < num_srcs; ++src_num)
1537 {
1538 if (parent_instr->src_op(src_num) == operand(the_load))
1539 break;
1540 }
1541 the_load->remove();
1542 parent_instr->set_src_op(src_num, operand(loaded_var));
1543 }
1544 else
1545 {
1546 in_rrr *new_copy =
1547 new in_rrr(io_cpy, loaded_var->type(), operand(),
1548 operand(loaded_var));
1549 replace_instruction(the_load, new_copy);
1550 }
1551 delete the_load;
1552 }
1553 break;
1554 }
1555 case io_str:
1556 {
1557 in_rrr *the_store = (in_rrr *)the_instr;
1558 var_sym *stored_var;
1559 boolean is_var =
1560 is_simple_var_addr(the_store->dst_addr_op(), &stored_var);
1561 if (is_var)
1562 {
1563 operand data_op = the_store->src2_op();
1564 data_op.remove();
1565 instruction *new_instr;
1566 if (data_op.is_expr())
1567 {
1568 new_instr = data_op.instr();
1569 }
1570 else
1571 {
1572 new_instr =
1573 new in_rrr(io_cpy, stored_var->type(), operand(),
1574 data_op);
1575 }
1576
1577 replace_instruction(the_store, new_instr);
1578 new_instr->set_dst(operand(stored_var));
1579 delete the_store;
1580 }
1581 break;
1582 }
1583 case io_memcpy:
1584 {
1585 in_rrr *the_memcopy = (in_rrr *)the_instr;
1586 var_sym *loaded_var;
1587 boolean load_is_var =
1588 is_simple_var_addr(the_memcopy->src_addr_op(),
1589 &loaded_var);
1590 var_sym *stored_var;
1591 boolean store_is_var =
1592 is_simple_var_addr(the_memcopy->dst_addr_op(),
1593 &stored_var);
1594 if (load_is_var && store_is_var)
1595 {
1596 in_rrr *new_copy =
1597 new in_rrr(io_cpy, loaded_var->type(), operand(),
1598 operand(loaded_var));
1599 replace_instruction(the_memcopy, new_copy);
1600 new_copy->set_dst(operand(stored_var));
1601 delete the_memcopy;
1602 }
1603 else if (load_is_var)
1604 {
1605 operand dst_addr = the_memcopy->dst_addr_op();
1606 dst_addr.remove();
1607 in_rrr *new_store =
1608 new in_rrr(io_str, type_void, operand(), dst_addr,
1609 operand(loaded_var));
1610 replace_instruction(the_memcopy, new_store);
1611 delete the_memcopy;
1612 }
1613 else if (store_is_var)
1614 {
1615 operand src_addr = the_memcopy->src_addr_op();
1616 src_addr.remove();
1617 in_rrr *new_load =
1618 new in_rrr(io_lod, stored_var->type(), operand(),
1619 src_addr);
1620 replace_instruction(the_memcopy, new_load);
1621 new_load->set_dst(operand(stored_var));
1622 delete the_memcopy;
1623 }
1624 break;
1625 }
1626 default:
1627 break;
1628 }
1629 }
1630
1631 static void deallocate_operand(operand to_go)
1632 {
1633 if (!to_go.is_expr())
1634 return;
1635
1636 instruction *the_instr = to_go.instr();
1637 assert(the_instr != NULL);
1638 delete the_instr;
1639 }
1640
1641 static operand build_offset_operand(array_type *the_array_type,
1642 int num_dimensions)
1643 {
1644 array_type *follow_array = the_array_type;
1645 operand result = const_op(immed(0), type_ptr_diff);
1646 int dim_num = 0;
1647 while (dim_num < num_dimensions)
1648 {
1649 operand upper_op =
1650 operand_from_array_bound(follow_array->upper_bound());
1651 operand lower_op =
1652 operand_from_array_bound(follow_array->lower_bound());
1653 result *= ((upper_op - lower_op.clone()) + 1);
1654 result += lower_op;
1655
1656 type_node *next_type = follow_array->elem_type();
1657 assert(next_type != NULL);
1658 if (!next_type->is_array())
1659 return result;
1660 follow_array = (array_type *)next_type;
1661 ++dim_num;
1662 }
1663
1664 return result;
1665 }
1666
1667 static const char *last_field(immed_list *field_immeds)
1668 {
1669 const char *result = NULL;
1670 immed_list_iter the_iter(field_immeds);
1671 while (!the_iter.is_empty())
1672 {
1673 immed value = the_iter.step();
1674 if (!value.is_string())
1675 return NULL;
1676 result = value.string();
1677 }
1678 return result;
1679 }
1680
1681 static char *guess_base_var_name(in_array *the_array)
1682 {
1683 if (the_array == NULL)
1684 return NULL;
1685
1686 operand index = the_array->index(0);
1687 if (!index.is_instr())
1688 return NULL;
1689
1690 instruction *index_instr = index.instr();
1691 assert(index_instr != NULL);
1692 while (index_instr->opcode() == io_cvt)
1693 {
1694 in_rrr *the_cvt = (in_rrr *)index_instr;
1695 index = the_cvt->src_op();
1696 if (!index.is_instr())
1697 return NULL;
1698
1699 index_instr = index.instr();
1700 assert(index_instr != NULL);
1701 }
1702
1703 /* skip multiplication done for character strings */
1704 if (index_instr->opcode() == io_mul)
1705 {
1706 in_rrr *the_div = (in_rrr *)index_instr;
1707 index = the_div->src1_op();
1708 if (!index.is_instr())
1709 return NULL;
1710
1711 index_instr = index.instr();
1712 assert(index_instr != NULL);
1713 }
1714
1715 while (index_instr->opcode() == io_cvt)
1716 {
1717 in_rrr *the_cvt = (in_rrr *)index_instr;
1718 index = the_cvt->src_op();
1719 if (!index.is_instr())
1720 return NULL;
1721
1722 index_instr = index.instr();
1723 assert(index_instr != NULL);
1724 }
1725
1726 if (index_instr->opcode() != io_sub)
1727 return NULL;
1728
1729 in_rrr *the_sub = (in_rrr *)index_instr;
1730 operand subtracted = the_sub->src2_op();
1731
1732 while (subtracted.is_expr() && (subtracted.instr()->opcode() == io_cvt))
1733 {
1734 in_rrr *the_cvt = (in_rrr *)(subtracted.instr());
1735 subtracted = the_cvt->src_op();
1736 }
1737
1738 if (!subtracted.is_symbol())
1739 return NULL;
1740
1741 var_sym *the_symbol = subtracted.symbol();
1742 if (the_symbol == NULL)
1743 return NULL;
1744
1745 const char *sym_name = the_symbol->name();
1746 if (sym_name == NULL)
1747 return NULL;
1748
1749 char *suffix = strstr(sym_name, "_offset");
1750 if (suffix == NULL)
1751 return NULL;
1752
1753 if (strcmp(suffix, "_offset") != 0)
1754 return NULL;
1755
1756 char *result = new char[suffix - sym_name + 1];
1757 strncpy(result, sym_name, suffix - sym_name);
1758 result[suffix - sym_name] = 0;
1759 return result;
1760 }
1761
1762 /*
1763 * This function takes the operand ``original'' and breaks it up into
1764 * *op_a and *op_b such that
1765 *
1766 * *op_a + (the_var * (*op_b)) = original
1767 *
1768 * with as much of the operand as possible in *op_b.
1769 */
1770 static void linear_form(operand *op_a, operand *op_b, operand original,
1771 var_sym *the_var)
1772 {
1773 type_node *the_type = original.type();
1774
1775 switch (original.kind())
1776 {
1777 case OPER_NULL:
1778 {
1779 *op_a = operand();
1780 *op_b = operand();
1781 break;
1782 }
1783 case OPER_SYM:
1784 {
1785 if (original.symbol() == the_var)
1786 {
1787 *op_a = const_op(immed(0), the_type);
1788 *op_b = const_op(immed(1), the_type);
1789 }
1790 else
1791 {
1792 *op_a = original;
1793 *op_b = const_op(immed(0), the_type);
1794 }
1795 break;
1796 }
1797 case OPER_INSTR:
1798 {
1799 instruction *the_instr = original.instr();
1800 assert(the_instr != NULL);
1801
1802 switch(the_instr->opcode())
1803 {
1804 case io_cpy:
1805 case io_cvt:
1806 {
1807 in_rrr *the_rrr = (in_rrr *)the_instr;
1808 assert(the_rrr->src2_op().is_null());
1809 operand source1 = the_rrr->src1_op();
1810 source1.remove();
1811
1812 delete the_rrr;
1813
1814 linear_form(op_a, op_b, source1, the_var);
1815 break;
1816 }
1817 case io_add:
1818 {
1819 in_rrr *the_rrr = (in_rrr *)the_instr;
1820 operand source1 = the_rrr->src1_op();
1821 source1.remove();
1822 operand source2 = the_rrr->src2_op();
1823 source2.remove();
1824
1825 delete the_rrr;
1826
1827 operand op_a1, op_a2, op_b1, op_b2;
1828 linear_form(&op_a1, &op_b1, source1, the_var);
1829 linear_form(&op_a2, &op_b2, source2, the_var);
1830 *op_a = (op_a1 + op_a2);
1831 *op_b = (op_b1 + op_b2);
1832 break;
1833 }
1834 case io_sub:
1835 {
1836 in_rrr *the_rrr = (in_rrr *)the_instr;
1837 operand source1 = the_rrr->src1_op();
1838 source1.remove();
1839 operand source2 = the_rrr->src2_op();
1840 source2.remove();
1841
1842 delete the_rrr;
1843
1844 operand op_a1, op_a2, op_b1, op_b2;
1845 linear_form(&op_a1, &op_b1, source1, the_var);
1846 linear_form(&op_a2, &op_b2, source2, the_var);
1847 *op_a = (op_a1 - op_a2);
1848 *op_b = (op_b1 - op_b2);
1849 break;
1850 }
1851 case io_neg:
1852 {
1853 in_rrr *the_rrr = (in_rrr *)the_instr;
1854 assert(the_rrr->src2_op().is_null());
1855 operand source1 = the_rrr->src1_op();
1856 source1.remove();
1857
1858 delete the_rrr;
1859
1860 operand op_a1, op_b1;
1861 linear_form(&op_a1, &op_b1, source1, the_var);
1862 *op_a = -op_a1;
1863 *op_b = -op_b1;
1864 break;
1865 }
1866 case io_mul:
1867 {
1868 in_rrr *the_rrr = (in_rrr *)the_instr;
1869 operand source1 = the_rrr->src1_op();
1870 source1.remove();
1871 operand source2 = the_rrr->src2_op();
1872 source2.remove();
1873
1874 delete the_rrr;
1875
1876 operand op_a1, op_a2, op_b1, op_b2;
1877 linear_form(&op_a1, &op_b1, source1, the_var);
1878 linear_form(&op_a2, &op_b2, source2, the_var);
1879
1880 if (is_zero(op_b1))
1881 {
1882 nullify_operand(&op_b1);
1883 *op_a = (op_a1.clone() * op_a2);
1884 *op_b = (op_b2 * op_a1);
1885 }
1886 else if (is_zero(op_b2))
1887 {
1888 nullify_operand(&op_b2);
1889 *op_a = (op_a2.clone() * op_a1);
1890 *op_b = (op_b1 * op_a2);
1891 }
1892 else
1893 {
1894 operand new_a1 = op_a1.clone();
1895 operand new_a2 = op_a2.clone();
1896 operand new_b1 = op_b1.clone();
1897 operand new_b2 = op_b2.clone();
1898 *op_a = (op_a1 * op_a2);
1899 *op_b = ((new_b1 * new_a2) + (new_a1 * new_b2) +
1900 (operand(the_var) * op_b1 * op_b2));
1901 }
1902 break;
1903 }
1904 case io_lsl:
1905 {
1906 in_rrr *the_rrr = (in_rrr *)the_instr;
1907 operand source2 = the_rrr->src2_op();
1908 if (source2.is_expr())
1909 {
1910 instruction *source_2_instr = source2.instr();
1911 assert(source_2_instr != NULL);
1912 if (source_2_instr->opcode() == io_ldc)
1913 {
1914 in_ldc *the_ldc = (in_ldc *)source_2_instr;
1915 immed value = the_ldc->value();
1916 if (value.is_integer())
1917 {
1918 int shift_amount = value.integer();
1919 if ((shift_amount >= 0) &&
1920 (shift_amount < (int)sizeof(int)))
1921 {
1922 operand source1 = the_rrr->src1_op();
1923 source1.remove();
1924 delete the_rrr;
1925 linear_form(op_a, op_b, source1, the_var);
1926 if (shift_amount != 0)
1927 {
1928 i_integer i_const = 1 << shift_amount;
1929 *op_a *= const_op(i_const, the_type);
1930 *op_b *= const_op(i_const, the_type);
1931 }
1932 break;
1933 }
1934 }
1935 }
1936 }
1937 /* fall through */
1938 }
1939 default:
1940 {
1941 *op_a = original;
1942 *op_b = const_op(immed(0), the_type);
1943 break;
1944 }
1945 }
1946 break;
1947 }
1948 default:
1949 assert(FALSE);
1950 }
1951 }
1952
1953 static boolean is_zero(operand the_operand)
1954 {
1955 if (the_operand.kind() == OPER_NULL)
1956 return TRUE;
1957
1958 if (the_operand.kind() != OPER_INSTR)
1959 return FALSE;
1960
1961 instruction *the_instr = the_operand.instr();
1962 assert(the_instr != NULL);
1963 if (the_instr->opcode() != io_ldc)
1964 return FALSE;
1965
1966 in_ldc *the_ldc = (in_ldc *)the_instr;
1967 immed value = the_ldc->value();
1968
1969 if (value.kind() != im_int)
1970 return FALSE;
1971
1972 if (value.integer() == 0)
1973 return TRUE;
1974
1975 return FALSE;
1976 }
1977
1978 static void nullify_operand(operand *the_operand)
1979 {
1980 if (the_operand->kind() == OPER_INSTR)
1981 {
1982 instruction *the_instr = the_operand->instr();
1983 if (the_instr != NULL)
1984 delete the_instr;
1985 }
1986
1987 the_operand->set_null();
1988 }
1989
1990 static boolean is_subtracted(operand the_operand, var_sym *the_variable,
1991 boolean negated)
1992 {
1993 if (negated && (the_operand.kind() == OPER_SYM))
1994 {
1995 var_sym *the_symbol = the_operand.symbol();
1996 return (the_symbol == the_variable);
1997 }
1998
1999 if (the_operand.kind() != OPER_INSTR)
2000 return FALSE;
2001
2002 instruction *the_instr = the_operand.instr();
2003 if (the_instr == NULL)
2004 return FALSE;
2005
2006 switch (the_instr->opcode())
2007 {
2008 case io_cpy:
2009 {
2010 in_rrr *the_rrr = (in_rrr *)the_instr;
2011 return is_subtracted(the_rrr->src_op(), the_variable, negated);
2012 }
2013 case io_cvt:
2014 {
2015 in_rrr *the_cvt = (in_rrr *)the_instr;
2016 operand source_op = the_cvt->src_op();
2017 return is_subtracted(source_op, the_variable, negated);
2018 }
2019 case io_add:
2020 {
2021 in_rrr *the_rrr = (in_rrr *)the_instr;
2022 return (is_subtracted(the_rrr->src1_op(), the_variable, negated) ||
2023 is_subtracted(the_rrr->src2_op(), the_variable, negated));
2024 }
2025 case io_sub:
2026 {
2027 in_rrr *the_rrr = (in_rrr *)the_instr;
2028 return (is_subtracted(the_rrr->src1_op(), the_variable, negated) ||
2029 is_subtracted(the_rrr->src2_op(), the_variable, !negated));
2030 }
2031 case io_neg:
2032 {
2033 in_rrr *the_rrr = (in_rrr *)the_instr;
2034 assert(the_rrr->src2_op().is_null());
2035 return is_subtracted(the_rrr->src1_op(), the_variable, !negated);
2036 }
2037 default:
2038 return FALSE;
2039 }
2040 }
2041
2042 static operand remove_subtracted_variable(operand the_operand,
2043 var_sym *the_variable,
2044 boolean negated)
2045 {
2046 assert(the_operand.kind() == OPER_INSTR);
2047
2048 instruction *the_instr = the_operand.instr();
2049 assert(the_instr != NULL);
2050
2051 type_node *the_type = the_instr->result_type();
2052
2053 switch (the_instr->opcode())
2054 {
2055 case io_cpy:
2056 case io_cvt:
2057 {
2058 in_rrr *the_rrr = (in_rrr *)the_instr;
2059 operand source = the_rrr->src_op();
2060 source.remove();
2061
2062 delete the_rrr;
2063
2064 return remove_subtracted_variable(source, the_variable, negated);
2065 }
2066 case io_add:
2067 {
2068 in_rrr *the_rrr = (in_rrr *)the_instr;
2069 operand source1 = the_rrr->src1_op();
2070 operand source2 = the_rrr->src2_op();
2071 source1.remove();
2072 source2.remove();
2073
2074 delete the_rrr;
2075
2076 if (negated)
2077 {
2078 if (operand_is_var(source1, the_variable))
2079 return source2;
2080 if (operand_is_var(source2, the_variable))
2081 return source1;
2082 }
2083
2084 if (is_subtracted(source1, the_variable, negated))
2085 {
2086 return new in_rrr(io_add, the_type, operand(),
2087 remove_subtracted_variable(source1,
2088 the_variable,
2089 negated),
2090 source2);
2091 }
2092
2093 assert(is_subtracted(source2, the_variable, negated));
2094 return new in_rrr(io_add, the_type, operand(), source1,
2095 remove_subtracted_variable(source2,
2096 the_variable,
2097 negated));
2098 }
2099 case io_sub:
2100 {
2101 in_rrr *the_rrr = (in_rrr *)the_instr;
2102 operand source1 = the_rrr->src1_op();
2103 operand source2 = the_rrr->src2_op();
2104 source1.remove();
2105 source2.remove();
2106
2107 delete the_rrr;
2108
2109 if (negated && operand_is_var(source1, the_variable))
2110 return source2;
2111 if ((!negated) && operand_is_var(source2, the_variable))
2112 return source1;
2113
2114 if (is_subtracted(source1, the_variable, negated))
2115 {
2116 return new in_rrr(io_sub, the_type, operand(),
2117 remove_subtracted_variable(source1,
2118 the_variable,
2119 negated),
2120 source2);
2121 }
2122
2123 assert(is_subtracted(source2, the_variable, !negated));
2124 return new in_rrr(io_sub, the_type, operand(), source1,
2125 remove_subtracted_variable(source2,
2126 the_variable,
2127 !negated));
2128 }
2129 case io_neg:
2130 {
2131 in_rrr *the_rrr = (in_rrr *)the_instr;
2132 assert(the_rrr->src2_op().is_null());
2133 operand source1 = the_rrr->src1_op();
2134 source1.remove();
2135
2136 delete the_rrr;
2137
2138 return new in_rrr(io_neg, the_type, operand(),
2139 remove_subtracted_variable(source1,
2140 the_variable,
2141 !negated), operand());
2142 }
2143 default:
2144 assert(FALSE);
2145 }
2146
2147 assert(FALSE);
2148 return operand();
2149 }
2150
2151 static boolean operand_is_var(operand the_operand, var_sym *the_variable)
2152 {
2153 operand follow_op = the_operand;
2154
2155 while (follow_op.is_expr() &&
2156 ((follow_op.instr()->opcode() == io_cvt) ||
2157 (follow_op.instr()->opcode() == io_cpy)))
2158 {
2159 in_rrr *the_rrr = (in_rrr *)(follow_op.instr());
2160 follow_op = the_rrr->src1_op();
2161 }
2162
2163 if (follow_op.kind() != OPER_SYM)
2164 return FALSE;
2165
2166 return (the_variable == follow_op.symbol());
2167 }
2168
2169 static void mark_params_call_by_ref(tree_proc *the_tree_proc)
2170 {
2171 proc_symtab *the_proc_symtab = the_tree_proc->proc_syms();
2172 assert(the_proc_symtab != NULL);
2173
2174 sym_node_list_iter the_iter(the_proc_symtab->params());
2175 while (!the_iter.is_empty())
2176 {
2177 sym_node *the_symbol = the_iter.step();
2178 assert(the_symbol != NULL);
2179 assert(the_symbol->is_var());
2180 var_sym *the_var = (var_sym *)the_symbol;
2181 type_node *the_type = the_var->type();
2182 assert(the_type != NULL);
2183 if (the_type->is_ptr())
2184 {
2185 ptr_type *the_ptr = (ptr_type *)the_type;
2186 if (!the_ptr->ref_type()->unqual()->is_func())
2187 {
2188 type_node *new_type = the_type->copy();
2189 new_type->append_annote(k_call_by_ref, NULL);
2190 the_var->set_type(the_type->parent()->install_type(new_type));
2191 }
2192 }
2193 }
2194 }
2195
2196 static void fix_symtabs(base_symtab *the_symtab)
2197 {
2198 assert(the_symtab != NULL);
2199 fix_symtab(the_symtab);
2200 base_symtab_list_iter the_iter(the_symtab->children());
2201 while (!the_iter.is_empty())
2202 {
2203 base_symtab *this_symtab = the_iter.step();
2204 fix_symtabs(this_symtab);
2205 }
2206 }
2207
2208 static void fix_symtab(base_symtab *the_symtab)
2209 {
2210 sym_node_list_iter the_iter(the_symtab->symbols());
2211
2212 while (!the_iter.is_empty())
2213 {
2214 sym_node *the_symbol = the_iter.step();
2215 if (the_symbol->is_var())
2216 {
2217 if (strchr(the_symbol->name(), '_') != NULL)
2218 the_symbol->reset_userdef();
2219
2220 var_sym *the_var = (var_sym *)the_symbol;
2221 type_node *var_type = the_var->type();
2222 if (is_complex(var_type))
2223 the_var->set_type(complex_replacement(var_type));
2224 }
2225 }
2226
2227 type_node_list_iter type_iter(the_symtab->types());
2228 while (!type_iter.is_empty())
2229 {
2230 type_node *this_type = type_iter.step();
2231 replace_complex_in_type(this_type);
2232 }
2233 }
2234
2235 static boolean is_complex(type_node *the_type)
2236 {
2237 assert(the_type != NULL);
2238 if (the_type->op() != TYPE_STRUCT)
2239 return FALSE;
2240 struct_type *the_struct = (struct_type *)the_type;
2241 if (the_struct->num_fields() != 2)
2242 return FALSE;
2243 if (strcmp(the_struct->field_name(0), "_r") != 0)
2244 return FALSE;
2245 if (strcmp(the_struct->field_name(1), "_i") != 0)
2246 return FALSE;
2247 if (the_struct->field_type(0) != the_struct->field_type(1))
2248 return FALSE;
2249 if (the_struct->field_type(0)->op() != TYPE_FLOAT)
2250 return FALSE;
2251 return TRUE;
2252 }
2253
2254 static type_node *complex_replacement(type_node *complex_type)
2255 {
2256 assert(complex_type != NULL);
2257 assert(complex_type->op() == TYPE_STRUCT);
2258 struct_type *the_struct = (struct_type *)complex_type;
2259 assert(the_struct->num_fields() == 2);
2260 type_node *new_type =
2261 new array_type(the_struct->field_type(0), array_bound(0),
2262 array_bound(1));
2263 return complex_type->parent()->install_type(new_type);
2264 }
2265
2266 static void replace_complex_in_type(type_node *the_type)
2267 {
2268 assert(the_type != NULL);
2269 switch(the_type->op())
2270 {
2271 case TYPE_INT:
2272 case TYPE_FLOAT:
2273 case TYPE_VOID:
2274 break;
2275 case TYPE_PTR:
2276 {
2277 ptr_type *the_ptr = (ptr_type *)the_type;
2278
2279 type_node *base_type = the_ptr->ref_type();
2280 if (is_complex(base_type))
2281 the_ptr->set_ref_type(complex_replacement(base_type));
2282 else
2283 replace_complex_in_type(base_type);
2284
2285 break;
2286 }
2287 case TYPE_ARRAY:
2288 {
2289 array_type *the_array = (array_type *)the_type;
2290
2291 type_node *base_type = the_array->elem_type();
2292 if (is_complex(base_type))
2293 the_array->set_elem_type(complex_replacement(base_type));
2294 else
2295 replace_complex_in_type(base_type);
2296
2297 break;
2298 }
2299 case TYPE_FUNC:
2300 {
2301 func_type *the_function = (func_type *)the_type;
2302
2303 type_node *return_type = the_function->return_type();
2304 if (is_complex(return_type))
2305 {
2306 the_function->set_return_type(
2307 complex_replacement(return_type));
2308 }
2309 else
2310 {
2311 replace_complex_in_type(return_type);
2312 }
2313
2314 unsigned num_args = the_function->num_args();
2315 for (unsigned arg_num = 0; arg_num < num_args; ++arg_num)
2316 {
2317 type_node *arg_type = the_function->arg_type(arg_num);
2318 if (is_complex(arg_type))
2319 {
2320 the_function->set_arg_type(arg_num,
2321 complex_replacement(arg_type));
2322 }
2323 else
2324 {
2325 replace_complex_in_type(arg_type);
2326 }
2327 }
2328
2329 break;
2330 }
2331 case TYPE_GROUP:
2332 case TYPE_STRUCT:
2333 case TYPE_UNION:
2334 {
2335 struct_type *the_struct = (struct_type *)the_type;
2336
2337 unsigned num_fields = the_struct->num_fields();
2338 for (unsigned field_num = 0; field_num < num_fields; ++field_num)
2339 {
2340 type_node *field_type = the_struct->field_type(field_num);
2341 if (is_complex(field_type))
2342 {
2343 type_node *replacement = complex_replacement(field_type);
2344 assert(the_struct->parent()->is_ancestor(
2345 replacement->parent()));
2346 the_struct->set_field_type(field_num, replacement);
2347 }
2348 else
2349 {
2350 replace_complex_in_type(field_type);
2351 }
2352 }
2353
2354 break;
2355 }
2356 case TYPE_ENUM:
2357 break;
2358 case TYPE_CONST:
2359 case TYPE_VOLATILE:
2360 case TYPE_CALL_BY_REF:
2361 case TYPE_NULL:
2362 {
2363 modifier_type *the_modifier = (modifier_type *)the_type;
2364
2365 type_node *base_type = the_modifier->base();
2366 if (is_complex(base_type))
2367 the_modifier->set_base(complex_replacement(base_type));
2368 else
2369 replace_complex_in_type(base_type);
2370
2371 break;
2372 }
2373 default:
2374 assert(FALSE);
2375 }
2376 }
2377
2378 static void fix_complex_refs(tree_proc *the_proc)
2379 {
2380 assert(the_proc != NULL);
2381 the_proc->body()->map(&fix_complex_on_tree_node, NULL);
2382 }
2383
2384 static void fix_complex_on_tree_node(tree_node *the_node, void *)
2385 {
2386 assert(the_node != NULL);
2387 if (!the_node->is_instr())
2388 return;
2389
2390 tree_instr *the_tree_instr = (tree_instr *)the_node;
2391 the_tree_instr->instr_map(&fix_complex_on_instr, NULL, FALSE);
2392 }
2393
2394 static void fix_complex_on_instr(instruction *the_instr, void *)
2395 {
2396 assert(the_instr != NULL);
2397 type_node *result_type = the_instr->result_type();
2398 if (is_complex(result_type))
2399 {
2400 the_instr->set_result_type(complex_replacement(result_type));
2401
2402 if (the_instr->dst_op().is_symbol())
2403 {
2404 var_sym *dest_var = the_instr->dst_op().symbol();
2405 dest_var->set_addr_taken();
2406 in_rrr *the_store =
2407 new in_rrr(io_str, type_void, operand(), addr_op(dest_var),
2408 operand());
2409 the_instr->set_dst(operand());
2410 replace_instruction(the_instr, the_store);
2411 the_store->set_src2(operand(the_instr));
2412 fix_complex_store(the_store);
2413 return;
2414 }
2415 }
2416
2417 if ((the_instr->opcode() == io_str) || (the_instr->opcode() == io_memcpy))
2418 {
2419 in_rrr *the_store = (in_rrr *)the_instr;
2420 type_node *dest_type = the_store->dst_addr_op().type()->unqual();
2421
2422 assert(dest_type->is_ptr());
2423 ptr_type *dest_ptr = (ptr_type *)dest_type;
2424 type_node *object_type = dest_ptr->ref_type()->unqual();
2425 if (object_type->is_array())
2426 {
2427 array_type *the_array = (array_type *)object_type;
2428 if ((the_array->lower_bound() == array_bound(0)) &&
2429 (the_array->upper_bound() == array_bound(1)))
2430 {
2431 fix_complex_store(the_store);
2432 return;
2433 }
2434 }
2435 }
2436
2437 immed_list *field_immeds =
2438 (immed_list *)(the_instr->peek_annote(k_fields));
2439 if (field_immeds == NULL)
2440 return;
2441 const char *last_string = last_field(field_immeds);
2442 if (last_string == NULL)
2443 return;
2444
2445 boolean is_first;
2446 if (strcmp(last_string, "_r") == 0)
2447 is_first = TRUE;
2448 else if (strcmp(last_string, "_i") == 0)
2449 is_first = FALSE;
2450 else
2451 return;
2452
2453 type_node *original_type = the_instr->result_type();
2454
2455 if (original_type->unqual()->op() != TYPE_PTR)
2456 {
2457 warning_line(the_instr->parent(),
2458 "field annotation on instruction of non-pointer type");
2459 return;
2460 }
2461
2462 ptr_type *the_ptr = (ptr_type *)(original_type->unqual());
2463 type_node *base_type = the_ptr->ref_type();
2464 assert(base_type != NULL);
2465 unsigned elem_size = base_type->size();
2466
2467 switch (the_instr->opcode())
2468 {
2469 case io_add:
2470 case io_sub:
2471 if (!is_first)
2472 {
2473 in_rrr *the_rrr = (in_rrr *)the_instr;
2474 operand the_operand = the_rrr->src2_op();
2475 if ((the_operand.type()->unqual()->op() != TYPE_INT) &&
2476 (the_instr->opcode() == io_add))
2477 {
2478 the_operand = the_rrr->src1_op();
2479 }
2480
2481 if (!the_operand.is_expr())
2482 {
2483 warning_line(the_instr->parent(),
2484 "offset for field annotation is not "
2485 "constant");
2486 return;
2487 }
2488 instruction *offset_instr = the_operand.instr();
2489
2490 if (offset_instr->opcode() != io_ldc)
2491 {
2492 warning_line(the_instr->parent(),
2493 "offset for field annotation is not "
2494 "constant");
2495 return;
2496 }
2497 in_ldc *offset_ldc = (in_ldc *)offset_instr;
2498
2499 immed offset_value = offset_ldc->value();
2500 if (!offset_value.is_integer())
2501 {
2502 warning_line(the_instr->parent(),
2503 "offset for field annotation is not "
2504 "an integer constant");
2505 return;
2506 }
2507
2508 int offset = offset_value.integer();
2509 if (the_instr->opcode() == io_add)
2510 offset -= elem_size / target.addressable_size;
2511 else
2512 offset += elem_size / target.addressable_size;
2513 offset_ldc->set_value(immed(offset));
2514 }
2515 break;
2516 case io_ldc:
2517 if (!is_first)
2518 {
2519 in_ldc *the_ldc = (in_ldc *)the_instr;
2520 immed value = the_ldc->value();
2521 if (value.is_symbol())
2522 {
2523 sym_node *the_symbol = value.symbol();
2524 int offset = value.offset();
2525 offset -= elem_size;
2526 value = immed(the_symbol, offset);
2527 }
2528 else if (value.is_integer())
2529 {
2530 int offset = value.integer();
2531 offset -= elem_size / target.addressable_size;
2532 value = immed(offset);
2533 }
2534 else
2535 {
2536 warning_line(the_instr->parent(),
2537 "field annotation of bad ldc");
2538 return;
2539 }
2540 the_ldc->set_value(value);
2541 }
2542 break;
2543 case io_cvt:
2544 if (!is_first)
2545 {
2546 warning_line(the_instr->parent(),
2547 "field annotation of bad cvt");
2548 return;
2549 }
2550 break;
2551 case io_array:
2552 {
2553 in_array *the_array = (in_array *)the_instr;
2554 if (!is_first)
2555 {
2556 unsigned offset = the_array->offset();
2557 assert(offset >= elem_size);
2558 offset -= elem_size;
2559 the_array->set_offset(offset);
2560 }
2561 break;
2562 }
2563 default:
2564 warning_line(the_instr->parent(),
2565 "field annotation on bad instruction type");
2566 return;
2567 }
2568
2569 drop_last_field_name(the_instr);
2570
2571 type_node *new_type =
2572 new array_type(base_type, array_bound(0), array_bound(1));
2573 new_type = base_type->parent()->install_type(new_type);
2574 the_instr->set_result_type(new_type->ptr_to());
2575
2576 tree_instr *the_parent = NULL;
2577 instruction *instr_above = NULL;
2578 unsigned src_num;
2579 operand destination = the_instr->dst_op();
2580 if (destination.is_instr())
2581 {
2582 instr_above = destination.instr();
2583 assert(instr_above != NULL);
2584 unsigned num_srcs = instr_above->num_srcs();
2585 for (src_num = 0; src_num < num_srcs; ++src_num)
2586 {
2587 operand this_source = instr_above->src_op(src_num);
2588 if (this_source.is_expr())
2589 {
2590 if (this_source.instr() == the_instr)
2591 break;
2592 }
2593 }
2594 assert(src_num < num_srcs);
2595 the_instr->remove();
2596 }
2597 else
2598 {
2599 tree_instr *the_parent = the_instr->parent();
2600 assert(the_parent != NULL);
2601 the_parent->remove_instr(the_instr);
2602 the_instr->set_dst(operand());
2603 }
2604
2605 in_array *new_array = add_const_aref(operand(the_instr), is_first ? 0 : 1);
2606
2607 if (the_parent == NULL)
2608 {
2609 assert(instr_above != NULL);
2610 instr_above->set_src_op(src_num, operand(new_array));
2611 }
2612 else
2613 {
2614 new_array->set_dst(destination);
2615 the_parent->set_instr(new_array);
2616 }
2617 }
2618
2619 static void drop_last_field_name(instruction *the_instr)
2620 {
2621 immed_list *old_immeds = (immed_list *)(the_instr->get_annote(k_fields));
2622 assert(old_immeds != NULL);
2623 immed_list_iter the_iter(old_immeds);
2624 if (the_iter.is_empty())
2625 return;
2626 immed_list *new_immeds = new immed_list;
2627 while (TRUE)
2628 {
2629 immed this_immed = the_iter.step();
2630 if (the_iter.is_empty())
2631 break;
2632 new_immeds->append(this_immed);
2633 }
2634
2635 if (new_immeds->is_empty())
2636 delete new_immeds;
2637 else
2638 the_instr->append_annote(k_fields, new_immeds);
2639 return;
2640 }
2641
2642 static void fix_complex_store(in_rrr *the_store)
2643 {
2644 assert((the_store->opcode() == io_str) ||
2645 (the_store->opcode() == io_memcpy));
2646
2647 operand dest_addr = the_store->dst_addr_op();
2648
2649 operand src_addr;
2650 if (the_store->opcode() == io_memcpy)
2651 {
2652 src_addr = the_store->src_addr_op();
2653 src_addr.remove();
2654 }
2655 else
2656 {
2657 operand src_op = the_store->src2_op();
2658 while (src_op.is_expr() && (src_op.instr()->opcode() == io_cpy))
2659 {
2660 in_rrr *the_copy = (in_rrr *)(src_op.instr());
2661 src_op = the_copy->src_op();
2662 }
2663
2664 if (src_op.is_expr())
2665 {
2666 instruction *src_instr = src_op.instr();
2667 if (src_instr->opcode() != io_lod)
2668 return;
2669 in_rrr *src_lod = (in_rrr *)src_instr;
2670 src_addr = src_lod->src_addr_op();
2671 src_addr.remove();
2672 }
2673 else if (src_op.is_symbol())
2674 {
2675 var_sym *src_var = src_op.symbol();
2676 src_var->set_addr_taken();
2677 src_addr = const_op(immed(src_var), dest_addr.type());
2678 }
2679 else
2680 {
2681 return;
2682 }
2683 }
2684
2685 dest_addr.remove();
2686
2687 tree_node *place = the_store->owner();
2688
2689 dest_addr = make_re_evalable(dest_addr, place);
2690 src_addr = make_re_evalable(src_addr, place);
2691
2692 in_array *first_dest = add_const_aref(dest_addr.clone(), 0);
2693 in_array *first_src = add_const_aref(src_addr.clone(), 0);
2694 in_rrr *first_cpy =
2695 new in_rrr(io_memcpy, type_void, operand(), operand(first_dest),
2696 operand(first_src));
2697 place->parent()->insert_before(new tree_instr(first_cpy), place->list_e());
2698
2699 in_array *second_dest = add_const_aref(dest_addr, 1);
2700 in_array *second_src = add_const_aref(src_addr, 1);
2701 in_rrr *second_cpy =
2702 new in_rrr(io_memcpy, type_void, operand(), operand(second_dest),
2703 operand(second_src));
2704 replace_instruction(the_store, second_cpy);
2705
2706 delete the_store;
2707 }
2708
2709 /*
2710 * Here we only have to deal with Fortran 77 code, so the only way
2711 * there can be a side effect is through a function call. So we only
2712 * have to put the results of function calls into temporaries.
2713 */
2714 static operand make_re_evalable(operand the_op, tree_node *place)
2715 {
2716 if (!the_op.is_expr())
2717 return the_op;
2718
2719 instruction *the_instr = the_op.instr();
2720
2721 if (the_instr->opcode() == io_cal)
2722 {
2723 var_sym *temp_var =
2724 place->scope()->new_unique_var(the_instr->result_type());
2725 temp_var->reset_userdef();
2726
2727 the_instr->set_dst(operand(temp_var));
2728 tree_instr *new_tree_instr = new tree_instr(the_instr);
2729 place->parent()->insert_before(new_tree_instr, place->list_e());
2730
2731 return operand(temp_var);
2732 }
2733
2734 unsigned num_srcs = the_instr->num_srcs();
2735 for (unsigned src_num = 0; src_num < num_srcs; ++src_num)
2736 {
2737 operand this_op = the_instr->src_op(src_num);
2738 this_op.remove();
2739 this_op = make_re_evalable(this_op, place);
2740 the_instr->set_src_op(src_num, this_op);
2741 }
2742 return the_op;
2743 }
2744
2745 /*
2746 * Return an address which is simply the location of a symbol with
2747 * the proper type. The appropriate symbol is created as a
2748 * sub-variable and/or the type of the variable is set, as
2749 * appropriate. The exception is addresses calculated by array
2750 * refernce instructions -- these are returned unchanged, because the
2751 * base operand of the array will be handled elsewhere.
2752 */
2753 static operand simplify_address(operand old_address, type_node *new_type,
2754 const char *name)
2755 {
2756 const char *new_name = name;
2757 if ((new_name == NULL) && old_address.is_expr())
2758 {
2759 annote *field_annote =
2760 old_address.instr()->annotes()->peek_annote(k_fields);
2761 if (field_annote != NULL)
2762 {
2763 immed_list *field_immeds = field_annote->immeds();
2764 if ((field_immeds != NULL) && (!field_immeds->is_empty()))
2765 {
2766 immed last_immed = field_immeds->tail()->contents;
2767 if (last_immed.is_string())
2768 new_name = last_immed.string();
2769 }
2770 }
2771 }
2772
2773 if (old_address.is_expr() && (old_address.instr()->opcode() == io_array))
2774 return fold_real_1op_rrr(io_cvt, new_type->ptr_to(), old_address);
2775
2776 if (old_address.is_symbol())
2777 {
2778 var_sym *old_symbol = old_address.symbol();
2779 void *data = old_symbol->peek_annote(k_fixfortran_original_type);
2780 if (data != NULL)
2781 {
2782 type_node *original_type = (type_node *)data;
2783 return fold_real_1op_rrr(io_cvt, original_type, old_address);
2784 }
2785 }
2786
2787 immed immed_address;
2788 eval_status status = evaluate_const_expr(old_address, &immed_address);
2789 if ((status != EVAL_OK) || (!immed_address.is_symbol()) ||
2790 (!immed_address.symbol()->is_var()))
2791 {
2792 /*
2793 * This happens in the case of weird pointer arithmetic that
2794 * sf2c puts in to handle arrays of character strings. In
2795 * that case, we just give up on trying to put a type back on
2796 * an object.
2797 */
2798 return fold_real_1op_rrr(io_cvt, new_type->ptr_to(), old_address);
2799 }
2800
2801 var_sym *the_var = (var_sym *)(immed_address.symbol());
2802
2803 /*
2804 * Make sure it's not a temporary put in by snoot to hold a string
2805 * literal.
2806 */
2807 if (strstr(the_var->name(), "__tmp_string") != NULL)
2808 return fold_real_1op_rrr(io_cvt, new_type->ptr_to(), old_address);
2809
2810 if (old_address.is_expr())
2811 delete old_address.instr();
2812
2813 type_node *var_type = the_var->type()->unqual();
2814 if (is_complex(var_type))
2815 {
2816 in_ldc *new_ldc =
2817 new in_ldc(new_type->ptr_to(), operand(), immed_address);
2818 if ((new_type != complex_replacement(var_type)) ||
2819 (immed_address.offset() != 0))
2820 {
2821 immed_list *field_immeds = new immed_list;
2822 if (immed_address.offset() == 0)
2823 field_immeds->append(immed("_r"));
2824 else
2825 field_immeds->append(immed("_i"));
2826 new_ldc->append_annote(k_fields, field_immeds);
2827 }
2828 return operand(new_ldc);
2829 }
2830 else if (var_type->is_struct() || var_type->is_array())
2831 {
2832 if (the_var->parent_var() != NULL)
2833 {
2834 assert(the_var->offset() == 0);
2835 the_var = the_var->parent_var();
2836 var_type = the_var->type()->unqual();
2837 assert(var_type->is_struct());
2838 }
2839
2840 if (var_type->is_array() && new_type->is_array() &&
2841 (the_var->parent_var() == NULL) &&
2842 (var_type->size() == new_type->size()) &&
2843 (the_var->annotes()->peek_annote(k_fixfortran_fixed_array_type) ==
2844 NULL))
2845 {
2846 the_var->set_type(new_type);
2847 the_var->append_annote(k_fixfortran_fixed_array_type,
2848 new immed_list());
2849 }
2850 else if (var_type->is_array() && (the_var->type() == new_type))
2851 {
2852 /* empty */;
2853 }
2854 else if (var_type->is_array() && new_type->is_same(type_char))
2855 {
2856 /* empty */;
2857 }
2858 else
2859 {
2860 struct_type *var_struct;
2861
2862 if (var_type->op() == TYPE_GROUP)
2863 {
2864 var_struct = (struct_type *)var_type;
2865 }
2866 else if (var_type->is_array() &&
2867 (the_var->annotes()->peek_annote(k_fixfortran_fixed_array_type)
2868 != NULL))
2869 {
2870 if (the_var->parent_var() != NULL)
2871 {
2872 the_var = the_var->parent_var();
2873 var_type = the_var->type();
2874 assert(var_type->op() == TYPE_GROUP);
2875 var_struct = (struct_type *)var_type;
2876 }
2877 else
2878 {
2879 var_struct = new struct_type(TYPE_GROUP, var_type->size(),
2880 the_var->name(), 1);
2881 var_struct->set_field_name(0, the_var->name());
2882 var_struct->set_offset(0, 0);
2883 var_struct->set_field_type(0, var_type);
2884 var_type = var_type->parent()->install_type(var_struct);
2885 var_struct = (struct_type *)var_type;
2886
2887 var_sym *new_var =
2888 the_var->parent()->new_var(var_struct,
2889 the_var->name());
2890
2891 if (the_var->has_var_def())
2892 {
2893 var_def *old_def = the_var->definition();
2894 var_def *new_def =
2895 old_def->parent()->define_var(new_var,
2896 old_def->alignment());
2897 old_def->parent()->remove_def(old_def);
2898 while (!old_def->annotes()->is_empty())
2899 {
2900 annote *this_annote = old_def->annotes()->pop();
2901 new_def->annotes()->append(this_annote);
2902 }
2903 delete old_def;
2904 }
2905
2906 if (the_var->annotes()->peek_annote(k_common_block) !=
2907 NULL)
2908 {
2909 delete the_var->annotes()->get_annote(k_common_block);
2910 }
2911
2912 if (new_var->is_global())
2913 new_var->append_annote(k_common_block);
2914
2915 new_var->add_child(the_var, 0);
2916 the_var = new_var;
2917 }
2918 }
2919 else
2920 {
2921 const char *struct_name;
2922 if (var_type->is_struct())
2923 struct_name = ((struct_type *)var_type)->name();
2924 else
2925 struct_name = "0";
2926 var_struct =
2927 new struct_type(TYPE_GROUP, var_type->size(),
2928 struct_name, 0);
2929 var_type = var_type->parent()->install_type(var_struct);
2930 var_struct = (struct_type *)var_type;
2931 the_var->set_type(var_struct);
2932 if (the_var->is_global())
2933 the_var->append_annote(k_common_block, NULL);
2934 }
2935
2936 new_name = new_field_name(new_name, var_struct);
2937
2938 /*
2939 * There's no such thing as a single ``char'' variable in
2940 * Fortran -- strings are multiple characters and have
2941 * lengths, and the string of length one is just
2942 * considered a special case of that. So if we are
2943 * addressing something of type char, either it's
2944 * something internal created by sf2c, not the user; or
2945 * it's a character string, in which case the type will
2946 * already have been put on the object at some point with
2947 * a call to this function with an array type; or it is
2948 * something cast to ``char*'' for I/O or pointer
2949 * arithmetic, and it's hopeless to try to restore the
2950 * type at this point anyway. So we look at all
2951 * character arrays in the object at the right offset and
2952 * take the longest one and assume this is what is being
2953 * passed. This will be alright for all of the cases
2954 * just mentioned: if it's internal or weird pointer
2955 * arithmetic, it doesn't matter, and if it really is a
2956 * character string, we'll be passing a string at least
2957 * as large as what should be passed, which is always ok
2958 * in Fortran.
2959 */
2960 if (new_type->is_same(type_char))
2961 {
2962 int new_size =
2963 biggest_char_array_at_offset(var_struct,
2964 immed_address.offset());
2965 if (new_size != 0)
2966 {
2967 array_type *new_array =
2968 new array_type(new_type, array_bound(1),
2969 array_bound(new_size));
2970 new_type = new_type->parent()->install_type(new_array);
2971 }
2972 }
2973
2974 unsigned num_fields = var_struct->num_fields();
2975 unsigned field_num;
2976 for (field_num = 0; field_num < num_fields; ++field_num)
2977 {
2978 if ((var_struct->offset(field_num) == immed_address.offset())
2979 && (var_struct->field_type(field_num) == new_type))
2980 {
2981 break;
2982 }
2983 }
2984 if (field_num == num_fields)
2985 {
2986 var_struct->set_num_fields(num_fields + 1);
2987 var_struct->set_field_name(field_num, new_name);
2988 var_struct->set_offset(field_num, immed_address.offset());
2989 }
2990 assert(var_struct->parent()->is_ancestor(new_type->parent()));
2991 var_struct->set_field_type(field_num, new_type);
2992
2993 var_sym *new_var =
2994 the_var->find_child(immed_address.offset(), new_type);
2995 if (new_var == NULL)
2996 {
2997 new_var = the_var->build_child(immed_address.offset(),
2998 new_type, var_struct->field_name(field_num));
2999 }
3000 the_var = new_var;
3001 }
3002 }
3003 else
3004 {
3005 /*
3006 * Because sf2c casts everything to character pointers for
3007 * some kinds of I/O, we can get the address of something
3008 * cast to another type.
3009 */
3010 return cast_op(const_op(immed_address, var_type->ptr_to()),
3011 new_type->ptr_to());
3012 }
3013
3014 the_var->set_addr_taken();
3015 return const_op(immed(the_var), new_type->ptr_to());
3016 }
3017
3018 static boolean is_simple_var_addr(operand the_op, var_sym **the_var)
3019 {
3020 if (!the_op.is_expr())
3021 return FALSE;
3022 instruction *the_instr = the_op.instr();
3023 if (the_instr->opcode() != io_ldc)
3024 return FALSE;
3025 in_ldc *the_ldc = (in_ldc *)the_instr;
3026 immed value = the_ldc->value();
3027 if (!value.is_symbol())
3028 return FALSE;
3029 if (value.offset() != 0)
3030 return FALSE;
3031 sym_node *the_sym = value.symbol();
3032 if (!the_sym->is_var())
3033 return FALSE;
3034 var_sym *this_var = (var_sym *)the_sym;
3035 type_node *ldc_type = the_ldc->result_type()->unqual();
3036 if (!ldc_type->is_ptr())
3037 return FALSE;
3038 ptr_type *ldc_ptr = (ptr_type *)ldc_type;
3039 if (ldc_ptr->ref_type() != this_var->type())
3040 return FALSE;
3041 *the_var = this_var;
3042 return TRUE;
3043 }
3044
3045 static const char *new_field_name(const char *desired_name,
3046 struct_type *the_struct)
3047 {
3048 unsigned num_fields = the_struct->num_fields();
3049
3050 if ((desired_name != NULL) &&
3051 (the_struct->find_field_by_name(desired_name) >= num_fields))
3052 {
3053 return desired_name;
3054 }
3055
3056 const char *base = ((desired_name != NULL) ? desired_name : "");
3057
3058 char *tester = new char [strlen(base) + 100];
3059 sprintf(tester, "%s_", base);
3060 char *num_place = tester + strlen(base) + 1;
3061 unsigned test_num = 0;
3062 while (TRUE)
3063 {
3064 sprintf(num_place, "%u", test_num);
3065 if (the_struct->find_field_by_name(tester) >= num_fields)
3066 {
3067 const char *new_name = lexicon->enter(tester)->sp;
3068 delete tester;
3069 return new_name;
3070 }
3071 assert(test_num < UINT_MAX);
3072 ++test_num;
3073 }
3074 }
3075
3076 static int biggest_char_array_at_offset(struct_type *the_struct, int offset)
3077 {
3078 int result = 0;
3079 unsigned num_fields = the_struct->num_fields();
3080 for (unsigned field_num = 0; field_num < num_fields; ++field_num)
3081 {
3082 if (the_struct->offset(field_num) == offset)
3083 {
3084 type_node *field_type =
3085 the_struct->field_type(field_num)->unqual();
3086 if (field_type->is_array())
3087 {
3088 array_type *field_array = (array_type *)field_type;
3089 if (field_array->elem_type()->is_same(type_char))
3090 {
3091 assert(field_array->lower_bound().is_constant());
3092 assert(field_array->upper_bound().is_constant());
3093 int this_size =
3094 field_array->upper_bound().constant() -
3095 field_array->lower_bound().constant() + 1;
3096 if (this_size > result)
3097 result = this_size;
3098 }
3099 }
3100 }
3101 }
3102 return result;
3103 }
3104
3105 static type_node *original_op_type(operand the_op)
3106 {
3107 if (the_op.is_symbol())
3108 {
3109 var_sym *the_var = the_op.symbol();
3110 void *data = the_var->peek_annote(k_fixfortran_original_type);
3111 if (data != NULL)
3112 return (type_node *)data;
3113 else
3114 return the_var->type()->unqual();
3115 }
3116 else
3117 {
3118 return the_op.type();
3119 }
3120 }
3121
3122 static void mark_common_blocks(base_symtab *the_symtab)
3123 {
3124 sym_node_list_iter sym_iter(the_symtab->symbols());
3125 while (!sym_iter.is_empty())
3126 {
3127 sym_node *this_sym = sym_iter.step();
3128 if (this_sym->is_var())
3129 {
3130 var_sym *this_var = (var_sym *)this_sym;
3131 if (this_var->type()->is_struct())
3132 {
3133 if (this_var->annotes()->peek_annote(k_common_block) == NULL)
3134 {
3135 struct_type *old_struct =
3136 (struct_type *)(this_var->type());
3137 if (old_struct->op() != TYPE_GROUP)
3138 {
3139 struct_type *new_group =
3140 new struct_type(TYPE_GROUP, old_struct->size(),
3141 old_struct->name(), 0);
3142 type_node *new_type =
3143 old_struct->parent()->install_type(new_group);
3144 this_var->set_type(new_type);
3145 }
3146 this_var->append_annote(k_common_block, NULL);
3147 }
3148 }
3149 }
3150 }
3151 }
3152
3153 static void fix_defs(suif_object *the_object)
3154 {
3155 /*
3156 * Because of all the type changes we have done, some variables
3157 * might now have the wrong alignment set, so we reset all
3158 * alignments now.
3159 */
3160
3161 if (!the_object->is_def_obj())
3162 return;
3163 var_def *this_def = (var_def *)the_object;
3164 type_node *this_type = this_def->variable()->type();
3165 this_def->set_alignment(get_alignment(this_type));
3166 type_node *this_unqual = this_type->unqual();
3167 if (this_unqual->op() == TYPE_GROUP)
3168 {
3169 fix_group_type_for_initializations((struct_type *)this_unqual,
3170 this_def);
3171 }
3172 }
3173
3174 /*----------------------------------------------------------------------*
3175 End Private Function Implementations
3176 *----------------------------------------------------------------------*/