123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707 |
- /* T Y P E D E F I N I T I O N M E C H A N I S M */
- #include "debug.h"
- #include <alloc.h>
- #include <assert.h>
- #include <em.h>
- #include <pc_file.h>
- #include "LLlex.h"
- #include "const.h"
- #include "def.h"
- #include "idf.h"
- #include "main.h"
- #include "node.h"
- #include "scope.h"
- #include "type.h"
- #ifndef NOCROSS
- #include "target_sizes.h"
- int
- word_align = AL_WORD,
- int_align = AL_INT,
- long_align = AL_LONG,
- pointer_align = AL_POINTER,
- real_align = AL_REAL,
- struct_align = AL_STRUCT;
- arith
- word_size = SZ_WORD,
- int_size = SZ_INT,
- long_size = SZ_LONG,
- pointer_size = SZ_POINTER,
- real_size = SZ_REAL;
- #endif /* NOCROSS */
- extern arith max_int;
- struct type
- *bool_type,
- *char_type,
- *int_type,
- *long_type,
- *real_type,
- *string_type,
- *std_type,
- *text_type,
- *nil_type,
- *emptyset_type,
- *void_type,
- *error_type;
- CheckTypeSizes()
- {
- /* first, do some checking
- */
- if( int_size != word_size )
- fatal("integer size not equal to word size");
- if( word_size != 2 && word_size != 4 )
- fatal("illegal wordsize");
- if( pointer_size != 2 && pointer_size != 4 )
- fatal("illegal pointersize");
- if( options['d'] ) {
- if( long_size < int_size )
- fatal("longsize should be at least the integersize");
- if( long_size > 2 * int_size)
- fatal("longsize should be at most twice the integersize");
- }
- if( pointer_size < word_size )
- fatal("pointersize should be at least the wordsize");
- if( real_size != 4 && real_size != 8 )
- fatal("illegal realsize");
- }
- InitTypes()
- {
- /* First check the sizes of some basic EM-types
- */
- CheckTypeSizes();
- if( options['s'] ) {
- options['c'] = 0;
- options['d'] = 0;
- options['u'] = 0;
- options['C'] = 0;
- options['U'] = 0;
- }
- /* Initialize the predefined types
- */
- /* character type
- */
- char_type = standard_type(T_CHAR, 1, (arith) 1);
- char_type->enm_ncst = 128; /* only 7 bits ASCII characters */
-
- /* boolean type
- */
- bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
- bool_type->enm_ncst = 2;
- /* integer type
- */
- int_type = standard_type(T_INTEGER, int_align, int_size);
- /* real type
- */
- real_type = standard_type(T_REAL, real_align, real_size);
- /* long type
- */
- if( options['d'] )
- long_type = standard_type(T_LONG, long_align, long_size);
- /* string type
- */
- if( options['c'] )
- string_type = standard_type(T_STRING, pointer_align, pointer_size);
- /* an unique type for standard procedures and functions
- */
- std_type = construct_type(T_PROCEDURE, NULLTYPE);
- /* text (file of char) type
- */
- text_type = construct_type(T_FILE, char_type);
- text_type->tp_flags |= T_HASFILE;
- /* an unique type indicating an error
- */
- error_type = standard_type(T_ERROR, 1, (arith) 1);
- void_type = error_type;
- /* the nilvalue has an unique type
- */
- nil_type = construct_type(T_POINTER, error_type);
- /* the type of an empty set is generic
- */
- emptyset_type = construct_type(T_SET, error_type);
- emptyset_type->tp_size = word_size;
- emptyset_type->tp_align = word_align;
- }
- int
- fit(sz, nbytes)
- arith sz;
- {
- return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
- }
- struct type *
- standard_type(fund, algn, size)
- arith size;
- {
- register struct type *tp = new_type();
- tp->tp_fund = fund;
- tp->tp_palign = algn ? algn : 1;
- tp->tp_psize = size;
- tp->tp_align = word_align;
- tp->tp_size = WA(size);
- return tp;
- }
- struct type *
- construct_type(fund, tp)
- register struct type *tp;
- {
- /* fund must be a type constructor.
- * The pointer to the constructed type is returned.
- */
- register struct type *dtp = new_type();
- switch( dtp->tp_fund = fund ) {
- case T_PROCEDURE:
- case T_FUNCTION:
- dtp->tp_align = pointer_align;
- dtp->tp_size = 2 * pointer_size;
- break;
- case T_POINTER:
- dtp->tp_align = dtp->tp_palign = pointer_align;
- dtp->tp_size = dtp->tp_psize = pointer_size;
- break;
- case T_SET:
- case T_ARRAY:
- break;
- case T_FILE:
- dtp->tp_align = dtp->tp_palign = word_align;
- dtp->tp_size = dtp->tp_psize = sizeof(struct file);
- break;
- case T_SUBRANGE:
- assert(tp != 0);
- dtp->tp_align = tp->tp_align;
- dtp->tp_size = tp->tp_size;
- dtp->tp_palign = tp->tp_palign;
- dtp->tp_psize = tp->tp_psize;
- break;
- default:
- crash("funny type constructor");
- }
- dtp->next = tp;
- return dtp;
- }
- struct type *
- proc_type(parameters, n_bytes_params)
- struct paramlist *parameters;
- arith n_bytes_params;
- {
- register struct type *tp = construct_type(T_PROCEDURE, NULLTYPE);
- tp->prc_params = parameters;
- tp->prc_nbpar = n_bytes_params;
- return tp;
- }
- struct type *
- func_type(parameters, n_bytes_params, resulttype)
- struct paramlist *parameters;
- arith n_bytes_params;
- struct type *resulttype;
- {
- register struct type *tp = construct_type(T_FUNCTION, resulttype);
- tp->prc_params = parameters;
- tp->prc_nbpar = n_bytes_params;
- return tp;
- }
- chk_type_id(ptp, nd)
- register struct type **ptp;
- register struct node *nd;
- {
- register struct def *df;
- *ptp = error_type;
- if( ChkLinkOrName(nd) ) {
- if( nd->nd_class != Def )
- node_error(nd, "type expected");
- else {
- /* register struct def *df = nd->nd_def; */
- df = nd->nd_def;
- df->df_flags |= D_USED;
- if( df->df_kind & (D_TYPE | D_FTYPE | D_ERROR) ) {
- if( !df->df_type )
- node_error(nd, "type \"%s\" not declared",
- df->df_idf->id_text);
- else
- *ptp = df->df_type;
- }
- else
- node_error(nd,"identifier \"%s\" is not a type",
- df->df_idf->id_text);
- }
- }
- }
- struct type *
- subr_type(lb, ub)
- register struct node *lb, *ub;
- {
- /* Construct a subrange type from the constant expressions
- indicated by "lb" and "ub", but first perform some checks
- */
- register struct type *tp = lb->nd_type, *res;
- if( !TstTypeEquiv(lb->nd_type, ub->nd_type) ) {
- node_error(ub, "types of subrange bounds not equal");
- return error_type;
- }
- /* Check base type
- */
- if( !(tp->tp_fund & T_ORDINAL) ) {
- node_error(ub, "illegal base type for subrange");
- return error_type;
- }
- /* Check bounds
- */
- if( lb->nd_INT > ub->nd_INT )
- node_error(ub, "lower bound exceeds upper bound");
- /* Now construct resulting type
- */
- res = construct_type(T_SUBRANGE, tp);
- res->sub_lb = lb->nd_INT;
- res->sub_ub = ub->nd_INT;
- if (res->sub_lb >= 0) {
- if (ufit(res->sub_ub, 1)) {
- res->tp_psize = 1;
- res->tp_palign = 1;
- }
- else if (ufit(res->sub_ub, 2)) {
- res->tp_psize = 2;
- res->tp_palign = 2 < word_align ? 2 : word_align;
- }
- }
- else {
- if (fit(res->sub_lb, 1) && fit(res->sub_ub, 1)) {
- res->tp_psize = 1;
- res->tp_palign = 1;
- }
- else if (fit(res->sub_lb, 2) && fit(res->sub_ub, 2)) {
- res->tp_psize = 2;
- res->tp_palign = 2 < word_align ? 2 : word_align;
- }
- }
- return res;
- }
- getbounds(tp, plo, phi)
- register struct type *tp;
- arith *plo, *phi;
- {
- /* Get the bounds of a bounded type
- */
- assert(bounded(tp));
- if( tp->tp_fund & T_SUBRANGE ) {
- *plo = tp->sub_lb;
- *phi = tp->sub_ub;
- }
- else if( tp->tp_fund & T_INTEGER ) {
- *plo = -max_int;
- *phi = max_int;
- }
- else {
- *plo = 0;
- *phi = tp->enm_ncst - 1;
- }
- }
- struct type *
- set_type(tp, packed)
- register struct type *tp;
- unsigned short packed;
- {
- /* Construct a set type with base type "tp", but first
- perform some checks
- */
- struct type *basetype;
- static struct type *int_set = 0;
- arith lb, ub;
- if( tp == int_type ) {
- /* SET OF INTEGER */
- if( !int_set ) {
- struct node *lbn = new_node();
- struct node *ubn = new_node();
- lbn->nd_type = ubn->nd_type = int_type;
- /* the bounds are implicit */
- lbn->nd_INT = 0;
- ubn->nd_INT = max_intset;
- int_set = subr_type(lbn, ubn);
- }
- lb = 0;
- ub = max_intset;
- tp = int_set;
- }
- else {
- /* SET OF subrange/enumeration/char */
- if( !bounded(tp) ) {
- error("illegal base type of set");
- return error_type;
- }
- basetype = BaseType(tp);
- if( basetype == int_type ) {
- /* subrange of integers */
- getbounds(tp, &lb, &ub);
- if( lb < 0 || ub > max_intset ) {
- error("illegal integer base type of set");
- return error_type;
- }
- lb = 0;
- ub = max_intset;
- }
- else getbounds(basetype, &lb, &ub);
- }
- assert(lb == 0);
- /* at this point lb and ub denote the bounds of the host-type of the
- * base-type of the set
- */
- tp = construct_type(T_SET, tp);
- tp->tp_flags |= packed;
- tp->tp_psize = (ub - lb + 8) >> 3;
- tp->tp_size = WA(tp->tp_psize);
- tp->tp_align = word_align;
- if( !packed || word_size % tp->tp_psize != 0 ) {
- tp->tp_psize = tp->tp_size;
- tp->tp_palign = word_align;
- }
- else tp->tp_palign = tp->tp_psize;
- return tp;
- }
- arith
- ArrayElSize(tp, packed)
- register struct type *tp;
- {
- /* Align element size to alignment requirement of element type.
- Also make sure that its size is either a dividor of the word_size,
- or a multiple of it.
- */
- register arith algn;
- if( tp->tp_fund & T_ARRAY && !(tp->tp_flags & T_CHECKED) )
- ArraySizes(tp);
- if( !packed )
- return tp->tp_size;
- algn = align(tp->tp_psize, tp->tp_palign);
- if( word_size % algn != 0 ) {
- /* algn is not a dividor of the word size, so make sure it
- is a multiple
- */
- algn = WA(algn);
- }
- if( !fit(algn, (int) word_size) ) {
- error("element of array too large");
- }
- return algn;
- }
- ArraySizes(tp)
- register struct type *tp;
- {
- /* Assign sizes to an array type, and check index type
- */
- register struct type *index_type = IndexType(tp);
- register struct type *elem_type = tp->arr_elem;
- arith lo, hi, diff;
- tp->tp_flags |= T_CHECKED;
- tp->arr_elsize = ArrayElSize(elem_type,(int) IsPacked(tp));
- /* check index type
- */
- if( !bounded(index_type) ) {
- error("illegal index type");
- tp->tp_psize = tp->tp_size = tp->arr_elsize;
- tp->tp_palign = tp->tp_align = elem_type->tp_align;
- tp->next = error_type;
- return;
- }
- getbounds(index_type, &lo, &hi);
- diff = hi - lo;
- if( diff < 0 || !fit(diff, (int) word_size) ) {
- error("too many elements in array");
- }
- if( (unsigned long)full_mask[(int) pointer_size]/(diff + 1) <
- tp->arr_elsize ) {
- error("array too large");
- }
- tp->tp_psize = (diff + 1) * tp->arr_elsize;
- tp->tp_palign = (word_size % tp->tp_psize) ? word_align : tp->tp_psize;
- tp->tp_size = WA(tp->tp_psize);
- tp->tp_align = word_align;
- /* generate descriptor and remember label.
- */
- tp->arr_ardescr = ++data_label;
- C_df_dlb(data_label);
- C_rom_cst(lo);
- C_rom_cst(diff);
- C_rom_cst(tp->arr_elsize);
- }
- FreeForward(for_type)
- register struct forwtype *for_type;
- {
- if( !for_type ) return;
- FreeForward(for_type->f_next);
- free_node(for_type->f_node);
- free_forwtype(for_type);
- }
- chk_forw_types()
- {
- /* check all forward references (in pointer types) */
- register struct def *df = CurrentScope->sc_def;
- register struct def *ldf = NULLDEF;
- struct type *tp;
- while( df ) {
- if( df->df_kind & (D_FORWTYPE | D_FTYPE) ) {
- register struct forwtype *fw_type = df->df_fortype;
- if( df->df_kind == D_FORWTYPE ) {
- /* forward type not in this scope declared */
- register struct scopelist *scl = nextvisible(CurrVis);
- struct def *df1 = 0;
- while( scl ) {
- /* look in enclosing scopes */
- df1 = lookup(df->df_fortype->f_node->nd_IDF,
- scl->sc_scope, D_INUSE);
- if( df1 ) break;
- scl = nextvisible( scl );
- }
- if( !df1 || df1->df_kind != D_TYPE ) {
- /* bad forward type */
- tp = error_type;
- }
- else { /* ok */
- tp = df1->df_type;
- /* remove the def struct in the current scope */
- if( !ldf )
- CurrentScope->sc_def = df->df_nextinscope;
- else
- ldf->df_nextinscope = df->df_nextinscope;
- /* remove the def struct from symbol-table */
- remove_def(df);
- }
- }
- else /* forward type was resolved */
- tp = df->df_type;
- while( fw_type ) {
- if( tp == error_type )
- node_error(fw_type->f_node,
- "identifier \"%s\" is not a type",
- df->df_idf->id_text);
- fw_type->f_type->next = tp;
- #ifdef DBSYMTAB
- if (options['g']) {
- stb_addtp("(forward_type)", fw_type->f_type);
- }
- #endif
- fw_type = fw_type->f_next;
- }
- FreeForward( df->df_fortype );
- df->df_flags |= D_USED;
- if( tp == error_type )
- df->df_kind = D_ERROR;
- else
- df->df_kind = D_TYPE;
- }
- ldf = df;
- df = df->df_nextinscope;
- }
- }
- TstCaseConstants(nd, sel, sel1)
- register struct node *nd;
- register struct selector *sel, *sel1;
- {
- /* Insert selector of nested variant (sel1) in tagvalue-table of
- current selector (sel).
- */
- while( nd ) {
- if( !TstCompat(nd->nd_type, sel->sel_type) )
- node_error(nd, "type incompatibility in caselabel");
- else if( sel->sel_ptrs ) {
- arith i = nd->nd_INT - sel->sel_lb;
- if( i < 0 || i >= sel->sel_ncst )
- node_error(nd, "case constant: out of bounds");
- else if( sel->sel_ptrs[i] != sel )
- node_error(nd,
- "record variant: multiple defined caselabel");
- else
- sel->sel_ptrs[i] = sel1;
- }
- nd = nd->nd_next;
- }
- }
- arith
- align(pos, al)
- arith pos;
- int al;
- {
- arith i;
- return pos + ((i = pos % al) ? al - i : 0);
- }
- int
- gcd(m, n)
- register int m, n;
- {
- /* Greatest Common Divisor
- */
- register int r;
- while( n ) {
- r = m % n;
- m = n;
- n = r;
- }
- return m;
- }
- int
- lcm(m, n)
- int m, n;
- {
- /* Least Common Multiple
- */
- return m * (n / gcd(m, n));
- }
- #ifdef DEBUG
- DumpType(tp)
- register struct type *tp;
- {
- if( !tp ) return;
- print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);
- print(" fund:");
- switch( tp->tp_fund ) {
- case T_ENUMERATION:
- print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
- case T_INTEGER:
- print("INTEGER"); break;
- case T_LONG:
- print("LONG"); break;
- case T_REAL:
- print("REAL"); break;
- case T_CHAR:
- print("CHAR"); break;
- case T_STRING:
- print("STRING"); break;
- case T_PROCEDURE:
- case T_FUNCTION:
- {
- register struct paramlist *par = ParamList(tp);
- if( tp->tp_fund == T_PROCEDURE )
- print("PROCEDURE");
- else
- print("FUNCTION");
- if( par ) {
- print("(");
- while( par ) {
- if( IsVarParam(par) ) print("VAR ");
- DumpType(TypeOfParam(par));
- par = par->next;
- }
- }
- break;
- }
- case T_FILE:
- print("FILE"); break;
- case T_STRINGCONST:
- print("STRINGCONST"); break;
- case T_SUBRANGE:
- print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
- break;
- case T_SET:
- print("SET"); break;
- case T_ARRAY:
- print("ARRAY");
- print("; element:");
- DumpType(tp->arr_elem);
- print("; index:");
- DumpType(tp->next);
- print(";");
- return;
- case T_RECORD:
- print("RECORD"); break;
- case T_POINTER:
- print("POINTER"); break;
- default:
- crash("DumpType");
- }
- if( tp->next && tp->tp_fund != T_POINTER ) {
- /* Avoid printing recursive types!
- */
- print(" next:(");
- DumpType(tp->next);
- print(")");
- }
- print(";");
- }
- #endif
|