main.cc

c到DHL的转换工具

        "DCOSH", /* cosh */
        "DTANH", /* tanh */
        "DLOG", /* log */
        "DLOG", /* F_log */
        "DSQRT", /* sqrt */
        "DSQRT", /* F_sqrt */
        "DEXP", /* exp */
        "DEXP", /* F_exp */
        "ALOG10", /* r_lg10 */
        "DLOG10", /* d_lg10 */
        "ISIGN", /* i_sign */
        "SIGN", /* r_sign */
        "DSIGN", /* d_sign */
        NULL, /* h_mod */
        "MOD", /* i_mod */
        "AMOD", /* r_mod */
        "DMOD", /* d_mod */
        "NINT", /* i_nint */
        "IDNINT", /* i_dnnt */
        "ANINT", /* r_nint */
        "DNINT", /* d_nint */
        "AINT", /* r_int */
        "DINT", /* d_int */
        "**", /* pow_ii */
        "**", /* pow_ri */
        "**", /* pow_di */
        "**", /* pow_ci */
        "**", /* pow_zi */
        "**", /* pow_hh */
        "**", /* pow_dd */
        "**", /* pow_zz */
        NULL, /* c_div */
        NULL, /* z_div */
        NULL, /* s_copy */
        NULL, /* s_cmp */
        NULL, /* s_cat */
        "AIMAG", /* r_imag */
        NULL, /* d_imag */
        "DIM", /* r_dim */
        NULL, /* sc_abs */
        NULL, /* sz_abs */
        NULL
      };

    sym_node_list_iter sym_iter(the_symtab->symbols());
    while (!sym_iter.is_empty())
      {
        sym_node *this_symbol = sym_iter.step();
        if (this_symbol->is_proc())
          {
            char **follow = &(pure_intrinsic_names[0]);
            unsigned long counter = 0;
            while (*follow != NULL)
              {
                if (strcmp(this_symbol->name(), *follow) == 0)
                  {
                    this_symbol->append_annote(k_pure_function);
                    char *fortran_name = intrinsic_fortran_names[counter];
                    if (fortran_name != NULL)
                      {
                        if (strcmp(fortran_name, "**") == 0)
                          {
                            this_symbol->append_annote(k_fortran_power_op);
                          }
                        else
                          {
                            immed_list *data =
                                    new immed_list(immed(fortran_name));
                            this_symbol->append_annote(k_fortran_intrinsic,
                                                       data);
                          }
                      }
                    break;
                  }
                ++follow;
                ++counter;
              }
          }
      }
  }

static void do_proc(tree_proc *the_tree_proc)
  {
    if (the_tree_proc->proc()->src_lang() == src_fortran)
      {
        error_line(0, the_tree_proc,
                   "function %s has already been converted to fortran",
                   the_tree_proc->proc()->name());
        errors = TRUE;
        return;
      }

    de_linearize(the_tree_proc);
    fix_symtabs(the_tree_proc->proc_syms());
    mark_params_call_by_ref(the_tree_proc);
    fix_complex_refs(the_tree_proc);
    mark_io_on_list(the_tree_proc->body());
    limit_complex_temp_scopes(the_tree_proc->body());
    walk(the_tree_proc, &fix_defs);

    the_tree_proc->proc()->append_annote(k_no_recursion);
    the_tree_proc->proc()->set_src_lang(src_fortran);
  }

static void de_linearize(tree_proc *the_proc)
  {
    assert(the_proc != NULL);

    if (the_proc->body() == NULL)
        return;

    aux_var_values = new alist;
    array_types = new alist;

    tree_node_list_iter body_iter(the_proc->body());
    while (!body_iter.is_empty())
      {
        tree_node *this_node = body_iter.step();
        assert(this_node != NULL);

        if (this_node->is_instr())
          {
            tree_instr *this_tree_instr = (tree_instr *)this_node;
            instruction *this_instr = this_tree_instr->instr();
            assert(this_instr != NULL);
            operand destination = this_instr->dst_op();
            if (destination.is_symbol())
              {
                var_sym *this_var = destination.symbol();
                assert(this_var != NULL);
                if ((strstr(this_var->name(), "_offset") != NULL)  ||
                    (strstr(this_var->name(), "_dim") != NULL)  ||
                    (strstr(this_var->name(), "_lb") != NULL)  ||
                    (strstr(this_var->name(), "_ub") != NULL) ||
                    (strstr(this_var->name(), "_strlen") != NULL))
                  {
                    if (aux_var_values->exists(this_var))
                      {
                        /*
                         * It can happen that one of these array linearization
                         * auxiliary variables is initialized more than once:
                         * f2c writes a ``prolog'' that initializes these
                         * things and it writes one prolog for every entry
                         * point.  It would only need to do the part of the
                         * prolog concerning parameters for each entry point,
                         * but it doesn't, it simply produces an entire prolog
                         * for each.  That means auxiliaries for things common
                         * to all entry points (most locals) are repeated.
                         * This still produces correct code, it's just
                         * redundant.  Since f2c writes all the prologs before
                         * the switch to branch to the label for the particular
                         * entry point, all the prologs are executed for every
                         * entry point.  Hence all the auxiliary variables that
                         * are written multiple times must be given the same
                         * values or else it would be wrong for some entry
                         * point.  So when we can just ignore the redundant
                         * assignment at this point.
                         */
                        continue;
                      }

                    aux_var_values->enter(this_var, this_tree_instr);
                  }
              }
          }
      }

    alist vars_to_delete;

    tree_node_list_iter base_body_iter(the_proc->body());
    while (!base_body_iter.is_empty())
      {
        tree_node *this_node = base_body_iter.step();
        assert(this_node != NULL);

        if (this_node->is_instr())
          {
            tree_instr *this_tree_instr = (tree_instr *)this_node;
            instruction *this_instr = this_tree_instr->instr();
            assert(this_instr != NULL);
            operand destination = this_instr->dst_op();
            if (destination.is_symbol())
              {
                var_sym *this_var = destination.symbol();
                assert(this_var != NULL);
                boolean is_a_base = FALSE;
                if (strstr(this_var->name(), "_base") != NULL)
                  {
                    fix_array_type_for_base_expr(this_instr);
                    is_a_base = TRUE;
                  }
                else if (strstr(this_var->name(), "_strbase") != NULL)
                  {
                    fix_array_type_for_str_base_expr(this_instr);
                    is_a_base = TRUE;
                  }

                if (is_a_base)
                  {
                    tree_node_list_e *this_elem = this_tree_instr->list_e();
                    the_proc->body()->remove(this_elem);
                    delete this_elem;
                    delete this_tree_instr;

                    if (!vars_to_delete.exists(this_var))
                        vars_to_delete.enter(this_var, this_var);
                  }
              }
          }
      }

    the_proc->map(&fix_arrays_on_node, NULL);

    alist_iter value_iter(aux_var_values);
    while (!value_iter.is_empty())
      {
        alist_e *this_alist_e = value_iter.step();
        assert(this_alist_e != NULL);
        aux_var_values->remove(this_alist_e);
        delete this_alist_e;
      }
    delete aux_var_values;
    aux_var_values = NULL;

    tree_node_list_iter del_body_iter(the_proc->body());
    while (!del_body_iter.is_empty())
      {
        tree_node *this_node = del_body_iter.step();
        assert(this_node != NULL);

        if (this_node->is_instr())
          {
            tree_instr *this_tree_instr = (tree_instr *)this_node;
            instruction *this_instr = this_tree_instr->instr();
            assert(this_instr != NULL);
            operand destination = this_instr->dst_op();
            if (destination.is_symbol())
              {
                var_sym *this_var = destination.symbol();
                assert(this_var != NULL);
                if ((strstr(this_var->name(), "_offset") != NULL) ||
                    (strstr(this_var->name(), "_dim") != NULL) ||
                    (strstr(this_var->name(), "_lb") != NULL) ||
                    (strstr(this_var->name(), "_ub") != NULL) ||
                    (strstr(this_var->name(), "_strlen") != NULL))
                  {
                    if (this_var->peek_annote(k_fixfortran_needed_aux) == NULL)
                      {
                        tree_node_list_e *this_elem =
                                this_tree_instr->list_e();
                        the_proc->body()->remove(this_elem);
                        delete this_elem;
                        delete this_tree_instr;

                        if (!vars_to_delete.exists(this_var))
                            vars_to_delete.enter(this_var, this_var);
                      }
                  }
              }
          }
      }

    alist_iter to_delete_iter(&vars_to_delete);
    while (!to_delete_iter.is_empty())
      {
        alist_e *this_alist_e = to_delete_iter.step();
        assert(this_alist_e != NULL);

        var_sym *this_var = (var_sym *)this_alist_e->key;
        assert(this_var != NULL);

        this_var->parent()->remove_sym(this_var);
        delete this_var;

        vars_to_delete.remove(this_alist_e);
        delete this_alist_e;
      }

    alist_iter type_iter(array_types);
    while (!type_iter.is_empty())
      {
        alist_e *this_alist_e = type_iter.step();
        assert(this_alist_e != NULL);
        array_types->remove(this_alist_e);
        delete this_alist_e;
      }
    delete array_types;
  }

/*
 * This function takes as an argument an instruction of the form
 *
 *     <str>_base = (int) &(<base_expr>[0])
 *
 * where <str> is a string (the name of the variable in Fortran) and
 * <base_expr> is the C expression for the base of the array.  This
 * function uses <str> to find the auxiliary variables for the array
 * type and sets the type of <base_expr> to that type 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 arrays that are local
 * variables, parameters, or elements of common blocks.
 */
void fix_array_type_for_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, "_base");
    assert(suffix != NULL);

    if (strcmp(suffix, "_base") != 0)
      {
        error_line(0, the_instr,
                   "variable name contains ``_base'' but not as a suffix;");
        error_line(0, the_instr,
                   "reconstruction of array 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;

    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();
      }

    type_node *base_type = aref_base_op.type()->unqual();
    if (!base_type->is_ptr())
      {
        error_line(0, the_instr->parent(),
                   "bad format for `%s_base' auxiliary expression;",
                   aux_base_name);
        error_line(0, the_instr->parent(),
                   "reconstruction of array types from auxiliary "
                   "variables failed");
        errors = TRUE;
        return;
      }
    ptr_type *the_pointer = (ptr_type *)base_type;

    type_node *element_type = the_pointer->ref_type()->unqual();

    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;
          }
      }