main.cc

c到DHL的转换工具

    if (aref_base_op.is_instr() && (aref_base_op.instr()->opcode() == io_ldc))
      {
        in_ldc *the_ldc = (in_ldc *)(aref_base_op.instr());
        immed value = the_ldc->value();
        if (value.is_symbol() && value.symbol()->is_var() &&
            (value.offset() == 0))
          {
            var_sym *the_var = (var_sym *)(value.symbol());
            if (the_var->is_param())
              {
                is_param = TRUE;
                param_var = the_var;
                assert(element_type->is_ptr());
                ptr_type *element_ptr = (ptr_type *)element_type;
                element_type = element_ptr->ref_type()->unqual();
              }
          }
      }

    if (element_type->is_array())
      {
        array_type *the_array_type = (array_type *)element_type;
        element_type = the_array_type->elem_type()->unqual();
      }

    if ((element_type->op() == TYPE_INT) &&
        (element_type->size() == target.size[C_char]))
      {
        element_type = string_type_for_base_name(aux_base_name,
                                                 base_aux_var_sym->parent());
      }

    type_node *new_type =
            register_type_for_base_name(aux_base_name, element_type,
                                        base_aux_var_sym->parent());

    if (is_param)
      {
        param_var->set_type(new_type->ptr_to());
        return;
      }

    operand new_op =
            simplify_address(aref_base_op.clone(), new_type, aux_base_name);
    if (new_op.is_expr())
        delete new_op.instr();
  }

/*
 * This function takes as an argument an instruction of the form
 *
 *     <str>_strbase = (int) <base_expr>
 *
 * where <str> is a string (the name of the variable in Fortran) and
 * <base_expr> is the C expression for the location of the string or
 * array of strings.  This function first checks for a <str>_base
 * auxiliary variable, and if it finds one, it returns without doing
 * anything because this means it is really an array of strings and it
 * will be handled by the array handling code in
 * fix_array_type_for_base_expr().  Otherwise, it uses <str> to find
 * the auxiliary variable for the length and sets the type of
 * *<base_expr> to a character array from one to that length if
 * *<base_expr>'s type comes from something like a variable or
 * structure member that can be changed so that other occurances of
 * *<base_expr> will have that type.
 *
 * This has the effect of restoring the types of strings that are
 * local variables, parameters, or elements of common blocks.
 */
void fix_array_type_for_str_base_expr(instruction *the_instr)
  {
    assert(the_instr != NULL);

    assert(the_instr->dst_op().is_symbol());
    var_sym *base_aux_var_sym = the_instr->dst_op().symbol();
    char *base_aux_var_name = base_aux_var_sym->name();

    char *suffix = strstr(base_aux_var_name, "_strbase");
    assert(suffix != NULL);

    if (strcmp(suffix, "_strbase") != 0)
      {
        error_line(0, the_instr,
                   "variable name contains ``_strbase'' but not as a suffix;");
        error_line(0, the_instr,
                   "reconstruction of string types from auxiliary variables "
                   "failed");
        errors = TRUE;
        return;
      }

    char *aux_base_name = new char[suffix - base_aux_var_name + 1];
    strncpy(aux_base_name, base_aux_var_name, suffix - base_aux_var_name);
    aux_base_name[suffix - base_aux_var_name] = 0;
    char *old_storage = aux_base_name;
    aux_base_name = lexicon->enter(aux_base_name)->sp;
    delete[] old_storage;

    char *aux_array_base_name = new char[strlen(aux_base_name) + 8];
    strcpy(aux_array_base_name, aux_base_name);
    strcat(aux_array_base_name, "_base");
    var_sym *aux_array_base_var =
            base_aux_var_sym->parent()->lookup_var(aux_array_base_name);
    delete[] aux_array_base_name;

    if (aux_array_base_var != NULL)
        return;

    operand aref_base_op(the_instr);
    while (aref_base_op.is_instr() &&
           ((aref_base_op.instr()->opcode() == io_cvt) ||
            (aref_base_op.instr()->opcode() == io_cpy)))
      {
        in_rrr *the_rrr = (in_rrr *)(aref_base_op.instr());
        aref_base_op = the_rrr->src_op();
      }

    if (aref_base_op.is_instr() &&
        (aref_base_op.instr()->opcode() == io_array))
      {
        in_array *the_aref = (in_array *)(aref_base_op.instr());
        aref_base_op = the_aref->base_op();
      }

    boolean is_param = FALSE;
    var_sym *param_var = NULL;

    while (aref_base_op.is_instr() &&
           (aref_base_op.instr()->opcode() == io_cvt))
      {
        in_rrr *the_cvt = (in_rrr *)(aref_base_op.instr());
        aref_base_op = the_cvt->src_op();
      }

    if (aref_base_op.is_symbol())
      {
        var_sym *the_var = aref_base_op.symbol();
        if (the_var->is_param())
          {
            is_param = TRUE;
            param_var = the_var;
          }
      }

    if (aref_base_op.is_instr() && (aref_base_op.instr()->opcode() == io_ldc))
      {
        in_ldc *the_ldc = (in_ldc *)(aref_base_op.instr());
        immed value = the_ldc->value();
        if (value.is_symbol() && value.symbol()->is_var() &&
            (value.offset() == 0))
          {
            var_sym *the_var = (var_sym *)(value.symbol());
            if (the_var->is_param())
              {
                is_param = TRUE;
                param_var = the_var;
              }
          }
      }

    type_node *new_type =
            string_type_for_base_name(aux_base_name,
                                      base_aux_var_sym->parent());

    if (is_param)
      {
        param_var->append_annote(k_fixfortran_original_type,
                                 param_var->type());
        param_var->set_type(new_type->ptr_to());
        return;
      }

    operand new_op =
            simplify_address(aref_base_op.clone(), new_type, aux_base_name);
    if (new_op.is_expr())
        delete new_op.instr();
  }

static void aux_sub_on_instr(instruction *the_instr, void *)
  {
    assert(the_instr != NULL);

    unsigned num_srcs = the_instr->num_srcs();
    for (unsigned src_num = 0; src_num < num_srcs; ++src_num)
      {
        operand this_operand = the_instr->src_op(src_num);
        if (this_operand.is_symbol())
          {
            var_sym *this_var = this_operand.symbol();
            alist_e *the_alist_e = aux_var_values->search(this_var);
            if (the_alist_e != NULL)
              {
                tree_instr *old_tree_instr = (tree_instr *)(the_alist_e->info);
                instruction *old_instr = old_tree_instr->instr();
                assert(old_instr != NULL);

                instruction *new_instr =
                        old_instr->clone(the_instr->parent()->scope());
                new_instr->set_dst(operand());
                the_instr->set_src_op(src_num, operand(new_instr));
              }
          }
      }

    /*
     * sf2c sometimes passes the location of one of these, such as &x_dim1, to
     * an I/O routine.  So if it's location is needed, we'd better not delete
     * it.
     */
    if (the_instr->opcode() == io_ldc)
      {
        in_ldc *the_ldc = (in_ldc *)the_instr;
        immed value = the_ldc->value();
        if (value.is_symbol())
          {
            sym_node *the_symbol = value.symbol();
            if (aux_var_values->search(the_symbol) != NULL)
              {
                the_symbol->append_annote(k_fixfortran_needed_aux,
                                          new immed_list);
              }
          }
      }
  }

static void fix_arrays_on_node(tree_node *the_node, void *)
  {
    assert(the_node != NULL);

    if (!the_node->is_instr())
        return;

    tree_instr *the_tree_instr = (tree_instr *)the_node;
    fix_arrays_on_instr(the_tree_instr->instr());
    the_tree_instr->instr_map(&fix_addresses, NULL, FALSE);
    the_tree_instr->instr_map(&inline_intrinsics_on_instr, NULL, FALSE);
    the_tree_instr->instr_map(&aux_sub_on_instr, NULL);
  }

static void fix_arrays_on_instr(instruction *the_instr)
  {
    assert(the_instr != NULL);

    unsigned num_srcs = the_instr->num_srcs();
    for (unsigned src_num = 0; src_num < num_srcs; ++src_num)
        fix_arrays_on_operand(the_instr->src_op(src_num));

    if (the_instr->opcode() != io_array)
        return;

    in_array *old_array = (in_array *)the_instr;
    if (old_array->dims() != 1)
      {
        error_line(0, the_instr->parent(),
                   "array reference with %d dimensions found",
                   old_array->dims());
        errors = TRUE;
        return;
      }

    char *base_var_name = guess_base_var_name(old_array);
    if (base_var_name == NULL)
      {
        /*
         *  If we can't find the base name, then this is not in the form of
         *  an array reference translated from Fortran by sf2c.  So assume
         *  that it is a C array reference to an sf2c generated array.  Such
         *  C arrays are generated to translate complicated Fortran internals
         *  such as string operations and I/O.
         */

        operand base_operand = old_array->base_op();
        base_operand.remove();
        assert(base_operand.type()->is_ptr());
        ptr_type *base_ptr = (ptr_type *)(base_operand.type());
        base_operand =
                simplify_address(base_operand, base_ptr->ref_type()->unqual(),
                                 NULL);
        old_array->set_base_op(base_operand);

        return;
      }

    type_node *base_type = array_type_from_aref(old_array);
    if (base_type == NULL)
        return;

    if (base_type->is_array())
      {
        array_type *the_array = (array_type *)base_type;
        base_type = the_array->elem_type();
      }

    base_symtab *the_symtab = the_instr->owner()->scope();

    unsigned num_dimensions;
    array_type *new_type =
            array_type_for_base_name(base_var_name, base_type,
                                     &num_dimensions);

    char *auxiliary_name =
            new char[strlen(base_var_name) + max_int_str_len + 5];
    strcpy(auxiliary_name, base_var_name);
    strcat(auxiliary_name, "_dim");
    char *number_place = auxiliary_name + strlen(base_var_name) + 4;

    operand offset_operand = old_array->offset_op();
    offset_operand.remove();
    if (!is_zero(offset_operand))
      {
        error_line(0, the_instr->parent(),
                   "Fortran array already contains a non-zero offset");
        errors = TRUE;
      }
    deallocate_operand(offset_operand);

    char *offset_var_name = new char[strlen(base_var_name) + 8];
    strcpy(offset_var_name, base_var_name);
    strcat(offset_var_name, "_offset");
    var_sym *offset_var = the_symtab->lookup_var(offset_var_name);

    if (offset_var == NULL)
      {
        error_line(0, the_instr->parent(),
                     "unable to find offset variable %s", offset_var_name);
        errors = TRUE;
      }
    delete[] offset_var_name;

    delete[] base_var_name;

    operand old_bound = old_array->bound(0);
    old_bound.remove();
    deallocate_operand(old_bound);

    operand base_operand = old_array->base_op();
    base_operand.remove();

    base_operand = simplify_address(base_operand, new_type, NULL);

    operand remaining_index = old_array->index(0);
    remaining_index.remove();

    offset_operand = build_offset_operand(new_type, num_dimensions);

    in_array *new_array = new in_array(old_array->result_type(), operand(),
                                       base_operand, old_array->elem_size(),
                                       num_dimensions, old_array->offset(),
                                       operand());
    new_array->annotes()->append(old_array->annotes());

    while (remaining_index.is_instr() &&
           (remaining_index.instr()->opcode() == io_cvt))
      {
        in_rrr *the_cvt = (in_rrr *)(remaining_index.instr());
        remaining_index = the_cvt->src_op();
      }

    /* skip multiplication done for character strings */
    if (remaining_index.is_instr() &&
        (remaining_index.instr()->opcode() == io_mul))
      {
        in_rrr *the_div = (in_rrr *)(remaining_index.instr());
        remaining_index = the_div->src1_op();
      }

    if (!is_subtracted(remaining_index, offset_var, FALSE))
      {
        error_line(0, the_instr->parent(),
                   "offset for Fortran array not subtracted");
        errors = TRUE;
      }
    remaining_index = remove_subtracted_variable(remaining_index, offset_var,
                                                 FALSE);
    unsigned dimension_num;
    for (dimension_num = 0; dimension_num + 1 < num_dimensions;
         ++dimension_num)
      {
        sprintf(number_place, "%u", dimension_num + 1);
        var_sym *bound_var = the_symtab->lookup_var(auxiliary_name);

        if (bound_var == NULL)
          {
            error_line(0, the_instr->parent(),