smt_astt array_sym_smt_ast::eq(smt_convt *ctx, smt_astt other) const { // We have two tuple_sym_smt_asts and need to create a boolean ast representing // their equality: iterate over all their members, compute an equality for // each of them, and then combine that into a final ast. tuple_sym_smt_astt ta = this; tuple_sym_smt_astt tb = to_tuple_sym_ast(other); assert(is_array_type(sort->get_tuple_type())); const array_type2t &arrtype = to_array_type(sort->get_tuple_type()); const struct_union_data &data = ctx->get_type_def(arrtype.subtype); smt_convt::ast_vec eqs; eqs.reserve(data.members.size()); // Iterate through each field and encode an equality. unsigned int i = 0; for(auto const &it : data.members) { type2tc tmparrtype( new array_type2t(it, arrtype.array_size, arrtype.size_is_infinite)); smt_astt side1 = ta->project(ctx, i); smt_astt side2 = tb->project(ctx, i); eqs.push_back(side1->eq(ctx, side2)); i++; } // Create an ast representing the fact that all the members are equal. return ctx->make_n_ary(ctx, &smt_convt::mk_and, eqs); }
char fortran_basic_type_is_implicit_none(type_t* t) { if (t == NULL) { return 0; } else if (is_implicit_none_type(t)) { return 1; } else if (is_array_type(t)) { return fortran_basic_type_is_implicit_none(array_type_get_element_type(t)); } else if (is_function_type(t)) { return fortran_basic_type_is_implicit_none(function_type_get_return_type(t)); } else if (is_lvalue_reference_type(t)) { return fortran_basic_type_is_implicit_none(reference_type_get_referenced_type(t)); } else if (is_pointer_type(t)) { return fortran_basic_type_is_implicit_none(pointer_type_get_pointee_type(t)); } else return 0; }
char fortran_is_array_type(type_t* t) { t = no_ref(t); return is_array_type(t) && !fortran_is_character_type(t); }
static void select_move(Node node, Symbol type_name) /*;select_move*/ { if (is_simple_type(type_name)) { if ((N_KIND(node) != as_null && is_simple_name(node) && !is_renaming(N_UNQ(node))) || (N_KIND(node) == as_selector || N_KIND(node) == as_index || N_KIND(node) == as_all)) { gen_address(node); gen_k(I_INDIRECT_MOVE, kind_of(type_name)); } else { gen_value(node); gen_k(I_MOVE, kind_of(type_name)); } } else { if (is_array_type(type_name)) { gen_value(node); gen(I_ARRAY_MOVE); } else { gen_value(node); gen_s(I_RECORD_MOVE, type_name); } } }
char fortran_is_character_type(type_t* t) { t = no_ref(t); return (is_array_type(t) && is_character_type(array_type_get_element_type(t))); }
char fortran_is_scalar_type(type_t* t) { return (!is_pointer_type(t) && !is_pointer_to_member_type(t) && !is_array_type(t) && !is_lvalue_reference_type(t) && !is_rvalue_reference_type(t) && !is_function_type(t) && !is_vector_type(t)); }
static type_t* adjust_type_for_parameter_type(type_t* orig) { type_t* result = get_unqualified_type(orig); if (is_function_type(result)) { result = get_pointer_type(result); } else if (is_array_type(result)) { result = get_pointer_type(array_type_get_element_type(result)); } return result; }
XI_CAST_FUNC(ast_pointer, tt, fe) { ast_type* t_elt = tt->element_type; // Cast from another pointer type // ------------------------------ if(is_pointer_type(fe->type)) { ast_type* f_elt = fe->type->as<ast_pointer_type>()->element_type; if(_builder.sametype(t_elt, f_elt)) return fe; // same type else return bitcast_to(tt, fe); } // Cast from an integer type // ------------------------- if(is_integer_type(fe->type)) { auto ft = fe->type->as<ast_integer_type>(); uint32_t fw = ft->bitwidth; bool fu = ft->is_unsigned; if(!fu) { return this->visit(tt, this->visit(_builder.get_integer_type(fw, true), fe)); } else { return new ast_cast(tt, ast_op::utop, fe); } } // Cast from an array type // ----------------------- if(is_array_type(fe->type)) { //TODO: check that array expression is addressable auto ft = fe->type->as<ast_array_type>(); ast_type* f_elt = ft->element_type; return new ast_addressof(tt, _builder.make_index_expr(fe, _builder.make_zero(_builder.get_size_type()))); } __throw_unhandled_ast_type(__FILE__, __LINE__, fe->type, "CAST_FUNC(ast_pointer)"); }
bool goto_symex_statet::constant_propagation(const expr2tc &expr) const { static unsigned int with_counter=0; // Don't permit const propagaion of infinite-size arrays. They're going to // be special modelling arrays that require special handling either at SMT // or some other level, so attempting to optimse them is a Bad Plan (TM). if (is_array_type(expr) && to_array_type(expr->type).size_is_infinite) return false; if (is_nil_expr(expr)) { return true; // It's fine to constant propagate something that's absent. } else if (is_constant_expr(expr)) { return true; } else if (is_symbol2t(expr) && to_symbol2t(expr).thename == "NULL") { // Null is also essentially a constant. return true; } else if (is_address_of2t(expr)) { return constant_propagation_reference(to_address_of2t(expr).ptr_obj); } else if (is_typecast2t(expr)) { return constant_propagation(to_typecast2t(expr).from); } else if (is_add2t(expr)) { forall_operands2(it, idx, expr) if(!constant_propagation(*it)) return false; return true; } else if (is_constant_array_of2t(expr))
smt_astt array_sym_smt_ast::ite(smt_convt *ctx, smt_astt cond, smt_astt falseop) const { // Similar to tuple ite's, but the leafs are arrays. tuple_sym_smt_astt true_val = this; tuple_sym_smt_astt false_val = to_tuple_sym_ast(falseop); assert(is_array_type(sort->get_tuple_type())); const array_type2t &array_type = to_array_type(sort->get_tuple_type()); std::string name = ctx->mk_fresh_name("tuple_array_ite::") + "."; symbol2tc result(sort->get_tuple_type(), name); smt_astt result_sym = ctx->convert_ast(result); const struct_union_data &data = ctx->get_type_def(array_type.subtype); // Iterate through each field and encode an ite. unsigned int i = 0; for(auto const &it : data.members) { array_type2tc arrtype( it, array_type.array_size, array_type.size_is_infinite); smt_astt truepart = true_val->project(ctx, i); smt_astt falsepart = false_val->project(ctx, i); smt_astt result_ast = truepart->ite(ctx, cond, falsepart); smt_astt result_sym_ast = result_sym->project(ctx, i); ctx->assert_ast(result_sym_ast->eq(ctx, result_ast)); i++; } return ctx->convert_ast(result); }
bool Type::is_array() const { return (is_array_type(_type_info)); }
void gen_subscript(Node node) /*;gen_subscript*/ { Symbol comp_type; Node index_name, array_node; Node index_list_node, subscript; Tuple index_type_list, subscripts, tup; Symbol array_name, array_type; int optimized; int index, seg, offset; Fortup ft1; #ifdef TRACE if (debug_flag) gen_trace_node("GEN_SUBSCRIPT", node); #endif array_node = N_AST1(node); index_list_node = N_AST2(node); array_name = N_UNQ(array_node); array_type = get_type(array_node); tup = SIGNATURE(array_type); index_type_list = (Tuple) tup[1]; comp_type = (Symbol) tup[2]; /* need tup_copy since subscripts used in tup_fromb below */ subscripts = tup_copy(N_LIST(index_list_node)); /* * Before applying the brute force method of the 'do-it-all' instruction * "subscript", which can solve any case, some optimizations will be * attempted. * * First, we try to compute the address of the indexed element directly, * when subscripts are immediate values and the index check can be done * at compile time: */ if ((Symbol)index_type_list[1] == symbol_none) { optimized = FALSE; } else if (!(is_unconstrained(array_type))) { index = compute_index(subscripts, index_type_list); optimized = index != -1; if (optimized) { if (has_static_size(comp_type)) { index = index * size_of(comp_type); if (is_simple_name(array_node) && !is_renaming(array_name) ) { if (is_global(array_name)) { reference_of(array_name); seg = REFERENCE_SEGMENT; offset = REFERENCE_OFFSET; /*gen_todo(I_PUSH_EFFECTIVE_ADDRESS,[seg, offset+index], * array_name + '(" + str(get_ivalue(subscripts(1))) * +/ [', '+str(get_ivalue(subscripts(i))): * i in [2..#subscripts] ] * + ")' ); */ gen_rc(I_PUSH_EFFECTIVE_ADDRESS, explicit_ref_new(seg, offset+index), ""); } else { gen_s(I_PUSH_EFFECTIVE_ADDRESS, array_name); if (index != 0) gen_kic(I_ADD_IMMEDIATE, mu_word, index, "offset"); } } else { gen_address(array_node); gen_ks(I_DISCARD_ADDR, 1, array_type); if (index != 0) gen_ki(I_ADD_IMMEDIATE, mu_word, index); } } else { optimized = FALSE; } } } else { optimized = FALSE; } /* * Nothing worked, we are left with the worse case, solved by the * "subscript" instruction */ if (!optimized) { FORTUP( index_name=(Node), index_type_list, ft1); subscript = (Node) tup_fromb(subscripts); gen_value(subscript) ; ENDFORTUP(ft1); gen_address(array_node); gen(I_SUBSCRIPT); } if (is_array_type(comp_type)) { gen_s(I_PUSH_EFFECTIVE_ADDRESS, comp_type); } }
static Tuple proc_init_rec(Symbol type_name, Tuple field_names, Node variant_node, Node out_param) /*;proc_init_rec*/ { /* * This is a subsidiary procedure to BUILD_PROC_INIT, which performs * the recursive part of construction of an initialization procedure * for a record type. * * Input: field_names is a list of component unique names (excluding * discriminants. Variant node is the AST for the variant part * of a component list. * variant_node is the variant part of the record declaration * and has the same structure as a case statement. * * out_param designates the object being initialized * * Output: the statement list required to initialize this fragment of * the record, or [] if not default initialization is needed. */ Tuple init_stmt, stmts; Node one_component, f_init, c_node, variant_list; Symbol f_type, f_name, ip; Fortup ft1; int empty_case; Tuple case_list, comp_case_list; Node choice_list, comp_list, disc_node; Node invariant_node, new_case, list_node, case_node; Tuple tup, index_list; int nb_dim, i; Node d_node, node, node1, node2, node3, node4, node5; Symbol one_index_type; /* process fixed part first. */ init_stmt = tup_new(0); FORTUP(f_name=(Symbol), field_names, ft1); one_component = new_selector_node(out_param, f_name); f_type = TYPE_OF(f_name); CONTAINS_TASK(type_name) = (char *) ((int)CONTAINS_TASK(type_name) | (int) CONTAINS_TASK(f_type)); f_init = (Node) default_expr(f_name); if (f_init != OPT_NODE) { init_stmt = tup_with(init_stmt, (char *) new_assign_node(one_component, remove_discr_ref(f_init, out_param))); } else if ((ip = INIT_PROC(base_type(f_type)))!=(Symbol)0) { init_stmt = tup_with(init_stmt, (char *) build_init_call(one_component, ip, f_type, out_param)); } else if (is_task_type(f_type)) { init_stmt = tup_with(init_stmt, (char *) new_assign_node(one_component, new_create_task_node(f_type))); } else if (is_access_type(f_type)) { init_stmt = tup_with(init_stmt, (char *) new_assign_node(one_component, new_null_node(f_type))); } /* if we have an aray then we have to check if its bounds are * compatible with the index subtypes (of the unconstrained array) * (This code was generated beforehand in type.c ("need_qual_r") but * it was wrong : we have to test the bounds only if the field is * present (case of variant record). * The generation of the tests is easier here */ if (is_array_type (f_type)) { tup = (Tuple) SIGNATURE(TYPE_OF(f_type)); index_list = tup_copy((Tuple) tup[1]); nb_dim = tup_size(index_list); for (i = 1; i <= nb_dim; i++) { one_index_type = (Symbol) (tup_fromb (index_list)); d_node = new_ivalue_node(int_const(i), symbol_integer); node1 = new_attribute_node(ATTR_O_FIRST, one_component, d_node, one_index_type); node2 = new_attribute_node(ATTR_O_LAST, one_component, d_node, one_index_type); node3 = new_attribute_node(ATTR_T_FIRST, new_name_node(one_index_type), OPT_NODE, one_index_type); node4 = new_attribute_node(ATTR_T_LAST, new_name_node(one_index_type), OPT_NODE, one_index_type); node5 = new_binop_node(symbol_or, new_binop_node(symbol_lt, node1, node3, symbol_boolean), new_binop_node(symbol_gt, node2, node4, symbol_boolean), symbol_boolean); node = node_new (as_list); make_if_node(node, tup_new1((char *) new_cond_stmts_node( new_binop_node(symbol_and, new_binop_node(symbol_le, node1, node2, symbol_boolean), node5, symbol_boolean), new_raise_node(symbol_constraint_error))), OPT_NODE); init_stmt = tup_with(init_stmt, (char *) (node)); } } ENDFORTUP(ft1); /* then build case statement to parallel structure of variant part. */ empty_case = TRUE; /* assumption */ if (variant_node != OPT_NODE) { disc_node= N_AST1(variant_node); variant_list = N_AST2(variant_node); case_list = tup_new(0); comp_case_list = N_LIST(variant_list); FORTUP(c_node=(Node), comp_case_list, ft1); choice_list = N_AST1(c_node); comp_list = N_AST2(c_node); invariant_node = N_AST1(comp_list); variant_node = N_AST2(comp_list); field_names = build_comp_names(invariant_node); stmts = proc_init_rec(type_name,field_names,variant_node, out_param); /*empty_case and= stmts = [];*/ empty_case = empty_case ? (tup_size(stmts)==0) : FALSE; new_case = (N_KIND(c_node) == as_others_choice) ? new_node(as_others_choice) : new_node(as_variant_choices); N_AST1(new_case) = copy_tree(choice_list); N_AST2(new_case) = new_statements_node(stmts); case_list = tup_with(case_list, (char *) new_case ); ENDFORTUP(ft1); if (! empty_case) { /* Build a case statement ruled by the value of the discriminant */ /* for this variant part. */ list_node = new_node(as_list); N_LIST(list_node) = case_list; case_node = new_node(as_case); N_AST1(case_node) = new_selector_node(out_param, N_UNQ(disc_node)); N_AST2(case_node) = list_node; init_stmt = tup_with(init_stmt, (char *) case_node ); } } return init_stmt; }
void gen_condition(Node node, Symbol destination, int branch_cond) /*;gen_condition*/ { /* IMPORTANT WARNING: destination is where to go when expression is * equal to branch_cond */ /* These maps are realized in procedures immediately following. * const * jump_false_code = { * ['=', I_JUMP_IF_FALSE], * ['!=', I_JUMP_IF_TRUE], * ['<', I_JUMP_IF_GREATER_OR_EQUAL], * ['>', I_JUMP_IF_LESS_OR_EQUAL], * ['<=', I_JUMP_IF_GREATER], * ['>=', I_JUMP_IF_LESS] }, * * jump_true_code = { * ['=', I_JUMP_IF_TRUE], * ['<', I_JUMP_IF_LESS], * ['>', I_JUMP_IF_GREATER], * ['<=', I_JUMP_IF_LESS_OR_EQUAL], * ['>=', I_JUMP_IF_GREATER_OR_EQUAL] }; */ Tuple tup; Node opnode, args, op1, op2; Symbol opcode, optype; #ifdef TRACE if (debug_flag) gen_trace_node("GEN_CONDITION", node); #endif if (N_KIND(node) == as_op) { opnode = N_AST1(node); args = N_AST2(node); opcode = N_UNQ(opnode); if (opcode == symbol_eq || opcode == symbol_ne || opcode == symbol_lt || opcode == symbol_gt || opcode == symbol_le || opcode == symbol_ge){ tup = N_LIST(args); op1 = (Node) tup[1]; op2 = (Node) tup[2]; gen_value(op1); gen_value(op2); optype = get_type(op1); if (is_simple_type(optype)) { if (is_float_type(optype)) gen_k(I_FLOAT_COMPARE, kind_of(optype)); else gen_k(I_COMPARE, kind_of(optype)); } else { if (is_record_type(optype)) { gen_s(I_PUSH_EFFECTIVE_ADDRESS, optype); } if (is_array_type(optype) && (opcode != symbol_eq) && (opcode != symbol_ne)) { gen(I_COMPARE_ARRAYS); } else { gen(I_COMPARE_STRUC); } } } else { gen_value(node); opcode = symbol_eq; } } else { gen_value(node); opcode = symbol_eq; } if (branch_cond) gen_s(jump_true_code(opcode), destination); else gen_s(jump_false_code(opcode), destination); }
static void put_typ P1 (const TYP *, tp) { if (tp == NIL_TYP) { return; } if (is_const_qualified (tp)) { lprintf ("const "); } if (is_volatile_qualified (tp)) { lprintf ("volatile "); } switch (tp->type) { case bt_void: case bt_schar: case bt_uchar: case bt_char: case bt_charu: case bt_ushort: case bt_short: case bt_uint16: case bt_uint32: case bt_int16: case bt_int32: case bt_ulong: case bt_long: case bt_float: case bt_longdouble: case bt_double: case bt_ellipsis: lprintf ("%s", nameoftype (tp)); break; case bt_pointer16: case bt_pointer32: if (is_array_type (tp)) { put_typ (referenced_type (tp)); lprintf ("[]"); } else { put_typ (referenced_type (tp)); lprintf ("*"); } break; case bt_union: lprintf ("union"); goto ucont; /*lint !e801*/ /* use of goto is deprecated */ case bt_struct: lprintf ("struct"); ucont: if (nameoftype (tp) != NIL_CHAR) { lprintf (" %s", nameoftype (tp)); } break; case bt_func: put_typ (returned_type (tp)); put_parms (parameters (tp)); break; case bt_bitfield: case bt_ubitfield: case bt_bbitfield: break; default: CANNOT_REACH_HERE (); } }
// Returns trhe if `e` has array type. bool has_array_type(Expr const& e) { return is_array_type(e.type()); }
/* * XXX warn about ``unsigned char *'' vs ``char *'', * unlike gcc */ static int compare_tlist(struct type_node *dest, struct type_node *src, int flag) { struct type_node *dest_start = dest; for (; dest != NULL && src != NULL; dest = dest->next, src = src->next) { if (src->type == TN_FUNCTION || dest->type == TN_FUNCTION) { if (dest->type != src->type) { /* XXX fix this later */ if (dest == dest_start) { /* * Ordinary function symbols are * compatible with pointers to * functions */ if (dest->type == TN_FUNCTION) { if (src->type == TN_POINTER_TO) { src = src->next; } else { return -1; } } else { if (dest->type == TN_POINTER_TO) { dest = dest->next; } else { return -1; } } } } } if (dest->type != src->type) { /* Pointer vs array vs function */ if (flag & CMPTY_ARRAYPTR) { if ((dest->type == TN_ARRAY_OF || src->type == TN_ARRAY_OF || dest->type == TN_VARARRAY_OF || src->type == TN_VARARRAY_OF) && (dest->type == TN_POINTER_TO || src->type == TN_POINTER_TO)) { continue; } } return -1; } switch (dest->type) { case TN_ARRAY_OF: case TN_VARARRAY_OF: if (flag & CMPTY_TENTDEC) { #if REMOVE_ARRARG if (!dest->have_array_size || !src->have_array_size) { #else if (dest->arrarg->const_value == NULL || src->arrarg->const_value == NULL) { #endif /* * probably * extern int foo[]; * int foo[123]; * -> OK! */ break; } } if (dest->arrarg_const != src->arrarg_const && ((flag & CMPTY_ARRAYPTR) == 0 || dest_start != dest)) { #if REMOVE_ARRARG if (!src->have_array_size || !dest->have_array_size) { #else if (src->arrarg->const_value == NULL || dest->arrarg->const_value == NULL) { #endif /* * One side has unspecified size, this * is OK! * extern char foo[]; * char (*p)[5] = &foo; * char bar[5]; * char (*p2)[] = &bar; */ break; } else { /* Array sizes differ */ return -1; } } break; case TN_POINTER_TO: break; case TN_FUNCTION: if (compare_tfunc(dest->tfunc, src->tfunc) == -1) { return -1; } break; } } if (dest != NULL || src != NULL) { /* One list is longer, so it differs by definition */ return -1; } return 0; } #endif /* #ifndef PREPROCESSOR */ int compare_types(struct type *dest, struct type *src, int flag) { int is_void_ptr = 0; /* 04/08/08: Changed this (for the better, hopefully!) */ if (dest->tlist != NULL && dest->tlist->type == TN_POINTER_TO && dest->tlist->next == NULL && dest->code == TY_VOID) { is_void_ptr = 1; } else if (src->tlist != NULL && src->tlist->type == TN_POINTER_TO && src->tlist->next == NULL && src->code == TY_VOID) { is_void_ptr = 1; } if (dest->code != src->code) { /* * Differing base type - This is ok if we have a void * pointer vs a non-void pointer, otherwise return error */ if (!is_void_ptr || src->tlist == NULL || dest->tlist == NULL) { return -1; } } if (flag & CMPTY_SIGN) { if (dest->sign != dest->sign) { /* Differing sign */ return -1; } } if (flag & CMPTY_CONST) { if (IS_CONST(dest->flags) != IS_CONST(src->flags)) { /* One is const-qualified */ /*return -1;*/ } } /* * 04/08/08: Skip the tlist comparison if this is void pointer * vs non-void pointer; Otherwise tlists of different length * will compare uneven, as in void * vs int **, which is wrong */ if (is_void_ptr) { return 0; } #ifndef PREPROCESSOR return compare_tlist(dest->tlist, src->tlist, flag); #else return -1; #endif } int check_init_type(struct type *ofwhat, struct expr *init) { if (ofwhat->tlist == NULL) { if (init->next != NULL) { } } else if (ofwhat->tlist->type == TN_ARRAY_OF) { if (init->type->code == TOK_STRING_LITERAL) { return 0; } else { struct expr *ex; for (ex = init; ex != NULL; ex = ex->next) { } } } return 0; } void copy_type(struct type *dest, const struct type *src, int fullcopy) { if (fullcopy) { memcpy(dest, src, sizeof *dest); } else { memcpy(dest, src, sizeof *dest); } } struct type_node * copy_tlist(struct type_node **dest, const struct type_node *src) { struct type_node *head; struct type_node *tail; struct type_node *tn; if (src == NULL) { *dest = NULL; return NULL; } head = tail = NULL; do { tn = n_xmalloc(sizeof *tn); memcpy(tn, src, sizeof *tn); if (head == NULL) { head = tail = tn; } else { tail->next = tn; tail = tail->next; } } while ((src = src->next) != NULL); *dest = head; return tail; } void set_type_sign(struct type *ty) { if (ty->code == TY_UCHAR || ty->code == TY_USHORT || ty->code == TY_UINT || ty->code == TY_ULONG || ty->code == TY_ULLONG) { ty->sign = TOK_KEY_UNSIGNED; } else if (!IS_FLOATING(ty->code) && ty->code != TY_STRUCT && ty->code != TY_UNION) { ty->sign = TOK_KEY_SIGNED; } } struct type * make_basic_type(int code) { #define N_TYPES (TY_MAX - TY_MIN) #if 0 static struct type basic_types[N_TYPES]; #endif static int inited; static struct type *basic_types; if (!inited) { int i; int nbytes = N_TYPES * sizeof(struct type); int need_mprotect = 1; basic_types = debug_malloc_pages(nbytes); if (basic_types == NULL) { /* * Probably debug_malloc_pages() doesn't work * on this system */ basic_types = n_xmalloc(nbytes); need_mprotect = 0; } memset(basic_types, 0, nbytes); for (i = 0; i < N_TYPES; ++i) { basic_types[i].code = i + TY_MIN; set_type_sign(&basic_types[i]); } inited = 1; if (need_mprotect) { /* * We make the array unwritable because it really * should not be written to; Modifying it is a bug * that has happend more than once. * * The void cast is necessary because of a broken * Solaris prototype that takes caddr_t :-/ */ mprotect((void *)basic_types, nbytes, PROT_READ); } } if (code < 0 || (code - TY_MIN) >= N_TYPES) { printf("BUG: bad code for make_basic_type: %d\n", code); abort(); } #if 0 if (code == TY_PSEUDEO_SIZE_T) { static struct type ty; static struct type *p; if (p == NULL) { ty = basic_types[TY_UINT]; } } #endif #if 0 /* As of Jan 6 2007, the basic types may not be modified anymore */ basic_types[code - TY_MIN].tlist = NULL; #endif return &basic_types[code - TY_MIN]; } struct type * make_void_ptr_type(void) { static struct type *ty; if (ty == NULL) { ty = make_basic_type(TY_VOID); ty = n_xmemdup(ty, sizeof *ty); append_typelist(ty, TN_POINTER_TO, NULL, NULL, NULL); } return ty; } struct type * make_array_type(int size, int is_wide_char) { struct type *ret = alloc_type(); if (is_wide_char) { ret->code = backend->get_wchar_t()->code; ret->sign = backend->get_wchar_t()->sign; } else { ret->code = TY_CHAR; if (CHAR_MAX == UCHAR_MAX) { /* XXX */ ret->sign = TOK_KEY_UNSIGNED; } else { ret->sign = TOK_KEY_SIGNED; } } ret->storage = TOK_KEY_STATIC; ret->tlist = alloc_type_node(); ret->tlist->type = TN_ARRAY_OF; ret->tlist->arrarg_const = size; #if REMOVE_ARRARG ret->tlist->have_array_size = 1; #endif return ret; } /* * Helper function for parse_declarator()- stores pointer/array-of/function * property (specified by ``type'' argument) with optional arguments type_arg * (for pointer/array-of) and tf (for function) in type specified by t * * 01/26/08: Extended to do some sanity checking (functions may not return * functions or arrays). This means some type constructions are now REQUIRED * to go through append_typelist()! May not be the best approach, needs * testing?! */ void append_typelist(struct type *t, int type, void *type_arg, struct ty_func *tf, struct token *tok) { struct type_node *te; struct expr *ex; (void) tok; /* XXX unneeded?!?! */ /* Allocate and insert new type node */ if (t->tlist == NULL) { te = t->tlist = t->tlist_tail = alloc_type_node(); te->prev = NULL; if (type == TN_FUNCTION) { /* * If the first node in the type list is a function * designator, this means we are dealing with a genuine * function declaration/definition (as opposed to a * pointer) */ t->is_func = 1; } } else { /* * 01/26/08: Some sanity checking! */ int tailtype = t->tlist_tail->type; if (tailtype == TN_ARRAY_OF || tailtype == TN_VARARRAY_OF) { if (type == TN_FUNCTION) { errorfl(tok, "Invalid declaration of `array of " "functions' - Maybe you meant `array " "of pointer to function'; `void (*ar[N])();'?"); return /* -1 XXX */ ; } } else if (tailtype == TN_FUNCTION) { if (type == TN_ARRAY_OF || type == TN_VARARRAY_OF) { errorfl(tok, "Invalid declaration of `function " "returning array' - If you really want " "to return an array by value, put it " "into a structure!"); return /* -1 XXX */ ; } else if (type == TN_FUNCTION) { errorfl(tok, "Invalid declaration of `function " "returning function' - You can at most " "return a pointer to a function; " "`void (*foo())();'"); return /* -1 XXX */ ; } } te = alloc_type_node(); te->prev = t->tlist_tail; t->tlist_tail->next = te; t->tlist_tail = t->tlist_tail->next; } te->next = NULL; te->type = type; switch (type) { case TN_VARARRAY_OF: case TN_ARRAY_OF: #if REMOVE_ARRARG ex = type_arg; if (ex->const_value == NULL) { /* Size not specified - extern char buf[]; */ te->have_array_size = 0; } else { te->have_array_size = 1; ex->const_value->type = n_xmemdup(ex->const_value->type, sizeof(struct type)); cross_convert_tyval(ex->const_value, NULL, NULL); te->arrarg_const = cross_to_host_size_t( ex->const_value); if (te->arrarg_const == 0) { /* * In GNU C, * int foo[0]; * may be a flexible array member */ te->have_array_size = 0; #if 0 errorfl(tok, "Cannot create zero-sized arrays"); #endif } } if (type == TN_VARARRAY_OF) { te->variable_arrarg = ex; } #else /* Using arrarg */ te->arrarg = type_arg; if (te->arrarg->const_value) { te->arrarg->const_value->type = n_xmemdup(te->arrarg->const_value->type, sizeof(struct type)); cross_convert_tyval(te->arrarg->const_value, NULL, NULL); te->arrarg_const = /* *(size_t *) */ cross_to_host_size_t( te->arrarg->const_value); /*->value; */ if (te->arrarg_const == 0) { /* * In GNU C, * int foo[0]; * may be a flexible array member */ te->arrarg->const_value = NULL; #if 0 errorfl(tok, "Cannot create zero-sized arrays"); #endif } } #endif /* REMOVE_ARRARG is disabled */ break; case TN_POINTER_TO: te->ptrarg = type_arg? *(int *)type_arg: 0; break; case TN_FUNCTION: te->tfunc = tf; break; } } static struct { char *name; int code; } basic_type_names[] = { { "char", TY_CHAR }, { "unsigned char", TY_UCHAR }, { "signed char", TY_SCHAR }, { "short", TY_SHORT }, { "unsigned short", TY_USHORT }, { "int", TY_INT }, { "unsigned int", TY_UINT }, { "long", TY_LONG }, { "unsigned long", TY_ULONG }, { "float", TY_FLOAT }, { "double", TY_DOUBLE }, { "long double", TY_LDOUBLE }, { "struct", TY_STRUCT }, { "union", TY_UNION }, { "enum", TY_ENUM }, { "void", TY_VOID }, { "long long", TY_LLONG }, { "unsigned long long", TY_ULLONG }, { "_Bool", TY_BOOL }, { NULL, 0 } }; char * ret_type_to_text(struct type *ty) { struct type_node *orig_tlist = NULL; char *ret; if (ty->tlist != NULL) { orig_tlist = ty->tlist; if (ty->tlist->type == TN_FUNCTION) { ty->tlist = ty->tlist->next; } else if (ty->tlist->type == TN_POINTER_TO && ty->tlist->next != NULL && ty->tlist->next->type == TN_FUNCTION) { ty->tlist = ty->tlist->next->next; } ret = type_to_text(ty); ty->tlist = orig_tlist; } else { ret = type_to_text(ty); } return ret; } char * type_to_text(struct type *dt) { struct type_node *t; char *buf = NULL; char *p = NULL; size_t size = 0; size_t used = 0; int i; for (t = dt->tlist; t != NULL; t = t->next) { switch (t->type) { case TN_ARRAY_OF: case TN_VARARRAY_OF: make_room(&buf, &size, used + 64); used += sprintf(buf+used, "an array of %d ", (int)t->arrarg_const); break; case TN_POINTER_TO: { char *quali = ""; if (t->ptrarg != 0) { switch (t->ptrarg) { case TOK_KEY_VOLATILE: quali = "volatile"; break; case TOK_KEY_CONST: quali = "constant"; break; case TOK_KEY_RESTRICT: quali = "restricted"; break; } } make_room(&buf, &size, used + 32); used += sprintf(buf+used, "a %s pointer to ", quali); break; } case TN_FUNCTION: make_room(&buf, &size, used + 32); used += sprintf(buf+used, "a function (with %d args) returning ", t->tfunc->nargs); break; } } #if 0 p = basic_type_names[dt->code - TY_MIN]; #endif for (i = 0; basic_type_names[i].name != NULL; ++i) { if (dt->code == basic_type_names[i].code) { p = basic_type_names[i].name; break; } } make_room(&buf, &size, strlen(p) + 5); used += sprintf(buf+used, "%s", p); if (dt->code == TY_STRUCT) { if (dt->tstruc && dt->tstruc->tag) { make_room(&buf, &size, used + strlen(dt->tstruc->tag) + 2); sprintf(buf+used, " %s", dt->tstruc->tag); } } return buf; } #ifndef PREPROCESSOR extern void put_ppc_llong(struct num *); /* * XXX same stupid size_t cross-compilaion bug as const_from_value().. * this stuff SUCKS!!! */ struct token * const_from_type(struct type *ty, int from_alignment, int extype, struct token *t) { struct token *ret = alloc_token(); size_t size; int size_t_size; #if 0 ret->type = TY_ULONG; /* XXX size_t */ #endif ret->type = backend->get_size_t()->code; if (from_alignment) { size = backend->get_align_type(ty); } else { size = backend->get_sizeof_type(ty, t); } /*ret->data = n_xmemdup(&size, sizeof size);*/ ret->data = n_xmalloc(16); /* XXX */ size_t_size = backend->get_sizeof_type(backend->get_size_t(), NULL); if (sizeof size == size_t_size) { memcpy(ret->data, &size, sizeof size); } else if (sizeof(int) == size_t_size) { unsigned int i = (unsigned int)size; memcpy(ret->data, &i, sizeof i); } else if (sizeof(long) == size_t_size) { unsigned long l = (unsigned long)size; memcpy(ret->data, &l, sizeof l); } else if (sizeof(long long) == size_t_size) { unsigned long long ll = (unsigned long long)size; memcpy(ret->data, &ll, sizeof ll); } else { unimpl(); } if (backend->abi == ABI_POWER64 && extype != EXPR_CONST && extype != EXPR_CONSTINIT /* What about EXPR_OPTCONSTINIT?! */ ) { struct num *n = n_xmalloc(sizeof *n); /* * XXX see definition of put_ppc_llong() for an * explanation of this mess */ n->type = ret->type; n->value = ret->data; put_ppc_llong(n); /*ret->data = llong_const;*/ ret->data2 = llong_const; } return ret; } /* * XXX this interface is ROTTEN!! * too easy to pass a ``size_t'' for value with ty=NULL by accident!! * * XXXX WOAH this was totally broken WRT cross-compilation! ``type'' * is interpreted as host type when dealing with ``value'', and as * target type too by making it the type of the token! Current ad-hoc * kludge sucks! */ struct token * const_from_value(void *value, struct type *ty) { struct token *ret = alloc_token(); size_t size; if (ty == NULL) { ret->type = TY_INT; size = backend->get_sizeof_type(make_basic_type( TY_INT), NULL);; } else { ret->type = ty->code; size = backend->get_sizeof_type(ty, NULL); } if (ty && (IS_LONG(ty->code) || IS_LLONG(ty->code))) { if (sizeof(long) == size) { /* Size matches - nothing to do */ ; } else { static long long llv; llv = *(int *)value; value = &llv; } } ret->data = n_xmemdup(value, size); if (backend->abi == ABI_POWER64 && ty != NULL && is_integral_type(ty) && size == 8) { struct num *n = n_xmalloc(sizeof *n); static struct num nullnum; *n = nullnum; n->type = ret->type; n->value = ret->data; put_ppc_llong(n); ret->data2 = llong_const; } return ret; } /* * Construct a floating point constant token of type ``type'' * containing ``value'' (which must be a string parsable by sscanf().) */ struct token * fp_const_from_ascii(const char *value, int type) { struct num *n; struct token *ret = n_xmalloc(sizeof *ret); n = cross_scan_value(value, type, 0, 0, 1); if (n == NULL) { return NULL; } /* * XXX token.data is ``struct ty_float'', not * ``struct num''. Because the interfaces are * still messed up, we have to get the current * ty_float corresponding to ``n'' from the * float list. This SUCKS! */ ret->data = float_const/*n->value*/; ret->type = type; ret->ascii = n_xstrdup(value); return ret; } struct token * const_from_string(const char *value) { struct token *ret = alloc_token(); struct type *ty; struct ty_string *tmpstr; tmpstr = alloc_ty_string(); tmpstr->size = strlen(value) + 1; tmpstr->str = n_xmemdup(value, tmpstr->size); tmpstr->is_wide_char = 0; ret->type = TOK_STRING_LITERAL; ty = make_array_type(tmpstr->size, tmpstr->is_wide_char); tmpstr->ty = ty; ret->data = tmpstr; return ret; } int is_integral_type(struct type *t) { if (t->tlist != NULL) { return 0; } if (IS_CHAR(t->code) || IS_SHORT(t->code) || IS_INT(t->code) || IS_LONG(t->code) || IS_LLONG(t->code) || t->code == TY_ENUM) { return 1; } return 0; } int is_floating_type(struct type *t) { if (t->tlist != NULL) { return 0; } if (t->code == TY_FLOAT || t->code == TY_DOUBLE || t->code == TY_LDOUBLE) { return 1; } return 0; } int is_arithmetic_type(struct type *t) { if (t->tlist != NULL) { return 0; } if (IS_FLOATING(t->code) || is_integral_type(t)) { return 1; } return 0; } int is_array_type(struct type *t) { struct type_node *tn; if (t->tlist == NULL) { return 0; } for (tn = t->tlist; tn != NULL; tn = tn->next) { if (tn->type != TN_ARRAY_OF) { return 0; } else { break; } } return 1; } int is_basic_agg_type(struct type *t) { if (t->tlist == NULL) { if (t->code == TY_STRUCT || t->code == TY_UNION) { return 1; } } else if (is_array_type(t)) { return 1; } return 0; } int is_scalar_type(struct type *t) { if (t->tlist == NULL && (t->code == TY_STRUCT || t->code == TY_UNION || t->code == TY_VOID)) { return 0; } return 1; } int is_arr_of_ptr(struct type *t) { struct type_node *tn; for (tn = t->tlist; tn != NULL; tn = tn->next) { if (tn->type == TN_POINTER_TO) { return 1; } else if (tn->type == TN_FUNCTION) { return 0; } } return 0; } int is_nullptr_const(struct token *constant, struct type *ty) { if (IS_INT(ty->code) && *(unsigned *)constant->data == 0) { return 1; } else if (IS_LONG(ty->code) && *(unsigned long *)constant->data == 0) { return 1; } return 0; } /* * The source type must be passed with a vreg because we need the null * pointer constant and object backing information it gives us */ int check_types_assign( struct token *t, struct type *left, struct vreg *right, int to_const_ok, int silent) { struct type *ltype = left; struct type *rtype = right->type; if (ltype == NULL || rtype == NULL) { printf("attempt to assign to/from value without type :(\n"); abort(); } /* * 01/26/08: Changed this to call is_modifyable(), which also * rules out assignment to const-qualified pointers */ /*if (ltype->tlist == NULL && ltype->is_const && !to_const_ok) { */ if (!is_modifyable(ltype) && !to_const_ok) { if (!silent) { errorfl(t, "Assignment to const-qualified object"); } return -1; } if (is_arithmetic_type(ltype)) { if (!is_arithmetic_type(rtype)) { if (ltype->code == TY_BOOL && rtype->tlist != NULL) { /* ok - pointer to bool */ return 0; } else { int allow = 0; if (rtype->tlist != NULL && is_integral_type(ltype)) { /* * 03/09/09: Give in and allow pointer * to integer assignment with a warning */ allow = 1; } if (!silent) { if (allow) { warningfl(t, "Assignment from non-arithmetic to " "arithmetic type"); } else { errorfl(t, "Assignment from non-arithmetic to " "arithmetic type"); } } if (allow) { return 0; } else { return -1; } } } else if (ltype->sign != rtype->sign && !right->from_const) { /* * Do not warn about signedness differences if the * right side is a constant! */ #if 0 /* XXX Too verbose */ warningfl(t, "Assignment from type of differing signedness"); #endif return 0; } return 0; } else if (ltype->tlist == NULL) { /* Must be struct/union */ if (rtype->tlist != NULL) { if (ltype->code == TY_BOOL) { return 0; } else { if (!silent) { /* 06/01/08: Warn, not error */ warningfl(t, "Assignment from pointer to non-pointer type"); } /* * 07/20/08: The return below was commented out! * That's wrong because pointer to struct will * compare assignable to struct * Why was this removed? */ return -1; } } else if (ltype->code == TY_BOOL) { return 0; /* _Bool b = ptr; is OK */ } else if (rtype->code != ltype->code || rtype->tstruc != ltype->tstruc) { if (!silent) { errorfl(t, "Assignment from incompatible type"); } return -1; } else { return 0; } } else { /* Left is pointer of some sort */ if (right->is_nullptr_const) { ; /* ok */ } else if (rtype->tlist == NULL) { if (!silent) { warningfl(t, "Assignment from non-pointer " "to pointer type"); } /* return -1;*/ } else if (rtype->code == TY_VOID && rtype->tlist->type == TN_POINTER_TO && rtype->tlist->next == NULL) { ; /* void pointer - compatible */ } else if (ltype->code == TY_VOID && ltype->tlist->type == TN_POINTER_TO && ltype->tlist->next == NULL) { ; /* void pointer - compatible */ } else if (compare_tlist(ltype->tlist, rtype->tlist, CMPTY_ARRAYPTR)) { if (!silent) { warningfl(t, "Assignment from incompatible pointer type" " (illegal in ISO C, and very " "probably not what you want)"); } else { /* * This is only used for transparent_union * right now... in that case we do not want * to allow this assignment because type- * checking is the whole point of that * language extension */ return -1; } return 0; } else if (!IS_CONST(ltype->flags) && IS_CONST(rtype->flags)) { if (!silent) { warningfl(t, "Assignment from const-qualified type " "to unqualified one"); } return 0; } else if (rtype->code != ltype->code && rtype->code != TY_VOID && ltype->code != TY_VOID /* XXX */ && (!IS_CHAR(ltype->code) || !IS_CHAR(rtype->code))) { if (type_without_sign(ltype->code) == type_without_sign(rtype->code)) { if (!silent) { warningfl(t, "Assignment from pointer of " "differing signedness"); } else { return -1; } return 0; } else { if (!silent) { warningfl(t, "Assignment from incompatible " "pointer type (illegal in ISO C, and " "very probably not what you want)"); } else { return -1; } #if 0 return -1; #endif return 0; } } else if (IS_CONST(ltype->flags) && !IS_CONST(rtype->flags) && ltype->tlist != NULL && ltype->tlist->next != NULL) { if (!silent) { warningfl(t, "ISO C does not allow assignment " "from `T **' to `const T **' without a " "cast (otherwise invalid code like " "`const char dont_modify; char *p; const " "char **cp = &p; *cp = &dont_modify; *p = 0;' " "would pass without warning)"); } return 0; } } return 0; } struct type * addrofify_type(struct type *ty) { struct type *ret = n_xmemdup(ty, sizeof *ty); struct type_node *tn; copy_tlist(&ret->tlist, ret->tlist); tn = alloc_type_node(); tn->type = TN_POINTER_TO; tn->next = ret->tlist; ret->tlist = tn; return ret; } int type_without_sign(int code) { int rc = code; if (code == TY_UCHAR) rc = TY_CHAR; else if (code == TY_USHORT) rc = TY_SHORT; else if (code == TY_UINT) rc = TY_INT; else if (code == TY_ULONG) rc = TY_LONG; else if (code == TY_ULLONG) rc = TY_LLONG; return rc; }
/* Object evaluation */ void gen_address(Node node) /*;gen_address*/ { /* * This procedure generates code for the o_expressions * or, in other words, the left-handsides. */ Node pre_node, array_node, range_node, lbd_node, ubd_node, record_node, field_node, id_node; Symbol node_name, type_name, record_name, record_type, field_name, comp_type, proc_name, return_type; int f_off, bse, off, nk; Fortup ft1; #ifdef TRACE if (debug_flag) gen_trace_node("GEN_ADDRESS", node); #endif while (N_KIND(node) == as_insert) { FORTUP(pre_node=(Node), N_LIST(node), ft1); compile(pre_node); ENDFORTUP(ft1); node = N_AST1(node); } node_name = N_UNQ(node); if (is_simple_name(node)) { type_name = get_type(node); if (is_renaming(node_name)) gen_ks(I_PUSH, mu_addr, node_name); else gen_s(I_PUSH_EFFECTIVE_ADDRESS, node_name); /* Arrays are treated in a different manner, depending on their */ /* nature: parameters, constants, variables... */ if (is_array_type(type_name)) { if (is_formal_parameter(node_name)) { type_name = assoc_symbol_get(node_name, FORMAL_TEMPLATE); } gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name); } } else { switch (nk = N_KIND(node)) { case as_raise: compile(node); break; case as_index: gen_subscript(node); break; case as_slice: array_node = N_AST1(node); range_node = N_AST2(node); /*range_name = N_UNQ(range_node); -- never used ds 7-8-85 */ /* Note: case of type simple name changed into range attribute */ /* by expander */ if (N_KIND(range_node) == as_attribute) { gen_attribute(range_node); } else { /* range */ lbd_node = N_AST1(range_node); ubd_node = N_AST2(range_node); gen_value(lbd_node); gen_value(ubd_node); } if (N_KIND(array_node) == as_attribute) { gen_attribute(array_node); } else { gen_address(array_node); } gen(I_ARRAY_SLICE); break; case as_selector: record_node = N_AST1(node); field_node = N_AST2(node); record_name = N_UNQ(record_node); record_type = get_type(record_node); field_name = N_UNQ(field_node); f_off = FIELD_OFFSET(field_name); if (f_off >= 0 && ((! has_discriminant(record_type)) || NATURE(field_name) == na_discriminant)){ if (is_simple_name(record_node) && !(is_renaming(record_name)) && is_global(record_name)) { reference_of(record_name); bse = REFERENCE_SEGMENT; off = REFERENCE_OFFSET; /* The SETL version has generate(I_PUSH_IMMEDIATE, mu_addr, * ref, field_name); * which we translate as (I_PUSH_EFFECTIVE_ADDRESS ... * ref = [bse, off+f_off]; * Replace use of explicit ref by PUSH_IMMEDIATE */ /* gen_rc(I_PUSH_IMMEDIATE, explicit_ref_new(bse, * off+f_off), ""); */ gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(bse)); gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(off+f_off)); } else { gen_address(record_node); if (f_off != 0 ) { gen_ki(I_ADD_IMMEDIATE, mu_word, f_off); } } if (is_array_type(comp_type=TYPE_OF(field_name))) { gen_s(I_PUSH_EFFECTIVE_ADDRESS, comp_type); } } else { gen_address(record_node); gen_s(I_PUSH_EFFECTIVE_ADDRESS, record_type); /* translating following assuming field_name is comment part of *-- instruction ds 7-5-86 * gen_i(I_SELECT, FIELD_NUMBER(field_name), field_name); */ gen_i(I_SELECT, (int) FIELD_NUMBER(field_name)); } break; case as_all: id_node = N_AST1(node); gen_value(id_node); if (is_array_type(N_TYPE(node))) gen_k(I_DEREF, mu_dble); break; case as_call: id_node = N_AST1(node); proc_name = N_UNQ(id_node); return_type = TYPE_OF(proc_name); gen_kc(I_DUPLICATE, kind_of(return_type), "place holder"); compile(node); /* processed from now as a procedure call */ break; case as_un_op: gen_unary(node); break; case as_op: gen_binary(node); break; case as_string_ivalue: gen_value(node); break; default: compiler_error_k("GEN_ADDRESS called with kind ", node); } } }