123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263 |
- /* C O D E G E N E R A T I O N R O U T I N E S */
- #include <stdlib.h>
- #include <string.h>
- #include "debug.h"
- #include <assert.h>
- #include <em.h>
- #include <em_reg.h>
- #include <em_abs.h>
- #include "LLlex.h"
- #include "Lpars.h"
- #include "def.h"
- #include "desig.h"
- #include "f_info.h"
- #include "idf.h"
- #include "main.h"
- #include "misc.h"
- #include "node.h"
- #include "required.h"
- #include "scope.h"
- #include "type.h"
- int fp_used;
- CodeFil()
- {
- if ( !options['L'] )
- C_fil_dlb((label) 1, (arith) 0);
- }
- routine_label(df)
- register struct def * df;
- {
- df->prc_label = ++data_label;
- C_df_dlb(df->prc_label);
- C_rom_scon(df->df_idf->id_text, (arith)(strlen(df->df_idf->id_text) + 1));
- }
- RomString(nd)
- register struct node *nd;
- {
- C_df_dlb(++data_label);
- /* A string of the string_type is null-terminated. */
- if( nd->nd_type == string_type )
- C_rom_scon(nd->nd_STR, nd->nd_SLE + 1); /* with trailing '\0' */
- else
- C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */
- nd->nd_SLA = data_label;
- }
- RomReal(nd)
- register struct node *nd;
- {
- if (! nd->nd_RLA) {
- C_df_dlb(++data_label);
- nd->nd_RLA = data_label;
- C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
- }
- }
- BssVar()
- {
- /* generate bss segments for global variables */
- register struct def *df = GlobalScope->sc_def;
- while( df ) {
- if( df->df_kind == D_VARIABLE ) {
- C_df_dnam(df->var_name);
- /* ??? undefined value ??? */
- C_bss_cst(df->df_type->tp_size, (arith) 0, 0);
- }
- df = df->df_nextinscope;
- }
- }
- arith
- CodeGtoDescr(sc)
- register struct scope *sc;
- {
- /* Create code for goto descriptors
- */
- register struct node *lb = sc->sc_lablist;
- int first = 1;
- while( lb ) {
- if( lb->nd_def->lab_descr ) {
- if( first ) {
- /* create local for target SP */
- sc->sc_off = -WA(pointer_size - sc->sc_off);
- C_ms_gto();
- first = 0;
- }
- C_df_dlb(lb->nd_def->lab_descr);
- C_rom_ilb(lb->nd_def->lab_no);
- C_rom_cst(sc->sc_off);
- }
- lb = lb->nd_next;
- }
- if( !first )
- return sc->sc_off;
- else
- return (arith) 0;
- }
- arith
- CodeBeginBlock(df)
- register struct def *df;
- {
- /* Generate code at the beginning of the main program,
- procedure or function.
- */
- arith StackAdjustment = 0;
- arith offset = 0; /* offset to save StackPointer */
- TmpOpen(df->prc_vis->sc_scope);
- if ( df->df_kind == D_MODULE) /* nothing */ ;
- else if (df->df_kind == D_PROGRAM ) {
- C_exp("_m_a_i_n");
- C_pro_narg("_m_a_i_n");
- C_ms_par((arith) 0);
- offset = CodeGtoDescr(df->prc_vis->sc_scope);
- CodeFil();
- /* initialize external files */
- call_ini();
- /* ignore floating point underflow */
- C_lim();
- C_loc((arith) (1 << EFUNFL));
- C_ior(int_size);
- C_sim();
- }
- else if (df->df_kind & (D_PROCEDURE | D_FUNCTION)) {
- struct type *tp;
- register struct paramlist *param;
- C_pro_narg(df->prc_name);
- C_ms_par(df->df_type->prc_nbpar);
- offset = CodeGtoDescr(df->prc_vis->sc_scope);
- CodeFil();
- if( options['t'] ) {
- C_lae_dlb(df->prc_label,(arith)0);
- C_cal("procentry");
- C_asp(pointer_size);
- }
- /* prc_bool is the local variable that indicates if the
- * function result is assigned. This and can be disabled
- * with the -R option. The variable, however, is always
- * allocated and initialized.
- */
- if( df->prc_res ) {
- C_zer((arith) int_size);
- C_stl(df->prc_bool);
- }
- for( param = ParamList(df->df_type); param; param = param->next) {
- if( !IsVarParam(param) ) {
- tp = TypeOfParam(param);
- if( IsConformantArray(tp) ) {
- /* Here, we have to make a copy of the
- array. We must also remember how much
- room is reserved for copies, because
- we have to adjust the stack pointer
- before we return.
- */
- if( !StackAdjustment ) {
- /* First time we get here
- */
- StackAdjustment = NewInt(0);
- C_loc((arith) 0);
- C_stl(StackAdjustment);
- }
- /* Address of array */
- C_lol(param->par_def->var_off);
- /* First compute size of the array */
- C_lol(tp->arr_cfdescr + word_size);
- C_inc();
- /* gives number of elements */
- C_lol(tp->arr_cfdescr + 2 * word_size);
- /* size of elements */
- C_mli(word_size);
- C_loc(word_size - 1);
- C_adi(word_size);
- C_loc(word_size - 1);
- C_com(word_size);
- C_and(word_size);
- C_dup(word_size);
- C_lol(StackAdjustment);
- C_adi(word_size);
- C_stl(StackAdjustment);
- /* remember stack adjustments */
- C_los(word_size); /* copy */
- C_lor((arith) 1);
- /* push new address of array
- ... downwards ... ???
- */
- C_stl(param->par_def->var_off);
- }
- }
- }
- }
- else {
- crash("(CodeBeginBlock)");
- /*NOTREACHED*/
- }
- if( offset ) {
- /* save SP for non-local jump */
- C_lor((arith) 1);
- C_stl(offset);
- }
- return StackAdjustment;
- }
- CodeEndBlock(df, StackAdjustment)
- register struct def *df;
- arith StackAdjustment;
- {
- if( df->df_kind == D_PROGRAM) {
- C_loc((arith) 0);
- C_cal("_hlt");
- }
- else if (df->df_kind & (D_PROCEDURE | D_FUNCTION)) {
- struct type *tp;
- if( StackAdjustment ) {
- /* remove copies of conformant arrays */
- C_lol(StackAdjustment);
- C_ass(word_size);
- FreeInt(StackAdjustment);
- }
- if( !options['n'] )
- RegisterMessages(df->prc_vis->sc_scope->sc_def);
- if( options['t'] ) {
- C_lae_dlb(df->prc_label,(arith)0);
- C_cal("procexit");
- C_asp(pointer_size);
- }
- if( tp = ResultType(df->df_type) ) {
- if( !options['R'] ) {
- C_lin((arith)LineNumber);
- C_lol(df->prc_bool);
- C_cal("_nfa");
- C_asp(word_size);
- }
- if( tp->tp_size == word_size )
- C_lol(-tp->tp_size);
- else if( tp->tp_size == 2 * word_size )
- C_ldl(-tp->tp_size);
- else {
- C_lal(-tp->tp_size);
- C_loi(tp->tp_size);
- }
- C_ret(tp->tp_size);
- }
- else
- C_ret((arith) 0);
- }
- else {
- crash("(CodeEndBlock)");
- /*NOTREACHED*/
- }
- C_end(- df->prc_vis->sc_scope->sc_off);
- TmpClose();
- }
- CodeExpr(nd, ds, true_label)
- register struct node *nd;
- register struct desig *ds;
- label true_label;
- {
- register struct type *tp = nd->nd_type;
- if( tp->tp_fund == T_REAL ) fp_used = 1;
- switch( nd->nd_class ) {
- case Value:
- switch( nd->nd_symb ) {
- case INTEGER:
- C_loc(nd->nd_INT);
- break;
- case REAL:
- RomReal(nd);
- C_lae_dlb(nd->nd_RLA, (arith) 0);
- C_loi(tp->tp_size);
- break;
- case STRING:
- if( tp->tp_fund == T_CHAR )
- C_loc(nd->nd_INT);
- else
- C_lae_dlb(nd->nd_SLA, (arith) 0);
- break;
- case NIL:
- C_zer(pointer_size);
- break;
- default:
- crash("(CodeExpr Value)");
- /*NOTREACHED*/
- }
- ds->dsg_kind = DSG_LOADED;
- break;
- case Uoper:
- CodeUoper(nd);
- ds->dsg_kind = DSG_LOADED;
- break;
- case Boper:
- CodeBoper(nd, true_label);
- ds->dsg_kind = DSG_LOADED;
- true_label = NO_LABEL;
- break;
- case Set: {
- register arith *st = nd->nd_set;
- register int i;
- ds->dsg_kind = DSG_LOADED;
- if( !st ) {
- C_zer(tp->tp_size);
- break;
- }
- for( i = tp->tp_size / word_size, st += i; i > 0; i--)
- C_loc(*--st);
- }
- break;
- case Xset:
- CodeSet(nd);
- ds->dsg_kind = DSG_LOADED;
- break;
- case Call:
- CodeCall(nd);
- ds->dsg_kind = DSG_LOADED;
- break;
- case NameOrCall: {
- /* actual procedure/function parameter */
- struct node *left = nd->nd_left;
- struct def *df = left->nd_def;
- if( df->df_kind & D_ROUTINE ) {
- int level = df->df_scope->sc_level;
- if( level <= 0 || (df->df_flags & D_EXTERNAL) )
- C_zer(pointer_size);
- else
- C_lxl((arith) (proclevel - level));
- C_lpi(df->prc_name);
- ds->dsg_kind = DSG_LOADED;
- break;
- }
- assert(df->df_kind == D_VARIABLE);
- assert(df->df_type->tp_fund & T_ROUTINE);
- CodeDesig(left, ds);
- break;
- }
- case Arrow:
- case Arrsel:
- case Def:
- case LinkDef:
- CodeDesig(nd, ds);
- break;
- case Cast: {
- /* convert integer to real */
- struct node *right = nd->nd_right;
- CodePExpr(right);
- Int2Real(right->nd_type->tp_size);
- ds->dsg_kind = DSG_LOADED;
- break;
- }
- case IntCoerc: {
- /* convert integer to long integer */
- struct node *right = nd->nd_right;
- CodePExpr(right);
- Int2Long();
- ds->dsg_kind = DSG_LOADED;
- break;
- }
- case IntReduc: {
- /* convert a long to an integer */
- struct node *right = nd->nd_right;
- CodePExpr(right);
- Long2Int();
- ds->dsg_kind = DSG_LOADED;
- break;
- }
- default:
- crash("(CodeExpr : bad node type)");
- /*NOTREACHED*/
- } /* switch class */
- if( true_label ) {
- /* Only for boolean expressions
- */
- CodeValue(ds, tp);
- C_zeq(true_label);
- }
- }
- CodeUoper(nd)
- register struct node *nd;
- {
- register struct type *tp = nd->nd_type;
- CodePExpr(nd->nd_right);
- switch( nd->nd_symb ) {
- case '-':
- assert(tp->tp_fund & T_NUMERIC);
- if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG )
- C_ngi(tp->tp_size);
- else
- C_ngf(tp->tp_size);
- break;
- case NOT:
- C_teq();
- break;
- case '(':
- break;
- default:
- crash("(CodeUoper)");
- /*NOTREACHED*/
- }
- }
- Operands(leftop, rightop)
- register struct node *leftop, *rightop;
- {
- CodePExpr(leftop);
- CodePExpr(rightop);
- }
- CodeBoper(expr, true_label)
- register struct node *expr; /* the expression tree itself */
- label true_label; /* label to jump to in logical exprs */
- {
- register struct node *leftop = expr->nd_left;
- register struct node *rightop = expr->nd_right;
- register struct type *tp = expr->nd_type;
- switch( expr->nd_symb ) {
- case '+':
- Operands(leftop, rightop);
- switch( tp->tp_fund ) {
- case T_INTEGER:
- case T_LONG:
- C_adi(tp->tp_size);
- break;
- case T_REAL:
- C_adf(tp->tp_size);
- break;
- case T_SET:
- C_ior(tp->tp_size);
- break;
- default:
- crash("(CodeBoper: bad type +)");
- }
- break;
- case '-':
- Operands(leftop, rightop);
- switch( tp->tp_fund ) {
- case T_INTEGER:
- case T_LONG:
- C_sbi(tp->tp_size);
- break;
- case T_REAL:
- C_sbf(tp->tp_size);
- break;
- case T_SET:
- C_com(tp->tp_size);
- C_and(tp->tp_size);
- break;
- default:
- crash("(CodeBoper: bad type -)");
- }
- break;
- case '*':
- Operands(leftop, rightop);
- switch( tp->tp_fund ) {
- case T_INTEGER:
- case T_LONG:
- C_mli(tp->tp_size);
- break;
- case T_REAL:
- C_mlf(tp->tp_size);
- break;
- case T_SET:
- C_and(tp->tp_size);
- break;
- default:
- crash("(CodeBoper: bad type *)");
- }
- break;
- case '/':
- Operands(leftop, rightop);
- if( tp->tp_fund == T_REAL )
- C_dvf(tp->tp_size);
- else
- crash("(CodeBoper: bad type /)");
- break;
- case DIV:
- case MOD:
- Operands(leftop, rightop);
- if( tp->tp_fund == T_INTEGER ) {
- C_cal(expr->nd_symb == MOD ? "_mdi" : "_dvi");
- C_asp(2 * tp->tp_size);
- C_lfr(tp->tp_size);
- }
- else if( tp->tp_fund == T_LONG) {
- C_cal(expr->nd_symb == MOD ? "_mdil" : "_dvil");
- C_asp(2 * tp->tp_size);
- C_lfr(tp->tp_size);
- }
- else
- crash("(CodeBoper: bad type MOD)");
- break;
- case '<':
- case LESSEQUAL:
- case '>':
- case GREATEREQUAL:
- case '=':
- case NOTEQUAL:
- CodePExpr(leftop);
- CodePExpr(rightop);
- tp = BaseType(rightop->nd_type);
- switch( tp->tp_fund ) {
- case T_INTEGER:
- case T_LONG:
- C_cmi(tp->tp_size);
- break;
- case T_REAL:
- C_cmf(tp->tp_size);
- break;
- case T_ENUMERATION:
- case T_CHAR:
- C_cmu(word_size);
- break;
- case T_POINTER:
- C_cmp();
- break;
- case T_SET:
- if( expr->nd_symb == GREATEREQUAL ) {
- /* A >= B is the same as A equals A + B
- */
- C_dup(2 * tp->tp_size);
- C_asp(tp->tp_size);
- C_ior(tp->tp_size);
- expr->nd_symb = '=';
- }
- else if( expr->nd_symb == LESSEQUAL ) {
- /* A <= B is the same as A - B = []
- */
- C_com(tp->tp_size);
- C_and(tp->tp_size);
- C_zer(tp->tp_size);
- expr->nd_symb = '=';
- }
- C_cms(tp->tp_size);
- break;
- case T_STRINGCONST:
- case T_ARRAY:
- C_loc((arith) IsString(tp));
- C_cal("_bcp");
- C_asp(2 * pointer_size + word_size);
- C_lfr(word_size);
- break;
- case T_STRING:
- C_cmp();
- break;
- default:
- crash("(CodeBoper : bad type COMPARE)");
- }
- truthvalue(expr->nd_symb);
- if( true_label != NO_LABEL )
- C_zeq(true_label);
- break;
- case IN:
- /* In this case, evaluate right hand side first! The INN
- instruction expects the bit number on top of the stack
- */
- CodePExpr(rightop);
- CodePExpr(leftop);
- if( rightop->nd_type == emptyset_type )
- C_and(rightop->nd_type->tp_size);
- else
- C_inn(rightop->nd_type->tp_size);
- if( true_label != NO_LABEL )
- C_zeq(true_label);
- break;
- case AND:
- case OR:
- Operands(leftop, rightop);
- if( expr->nd_symb == AND )
- C_and(tp->tp_size);
- else
- C_ior(tp->tp_size);
- if( true_label != NO_LABEL )
- C_zeq(true_label);
- break;
- default:
- crash("(CodeBoper Bad operator %s\n)",
- symbol2str(expr->nd_symb));
- }
- }
- /* truthvalue() serves as an auxiliary function of CodeBoper */
- truthvalue(relop)
- {
- switch( relop ) {
- case '<':
- C_tlt();
- break;
- case LESSEQUAL:
- C_tle();
- break;
- case '>':
- C_tgt();
- break;
- case GREATEREQUAL:
- C_tge();
- break;
- case '=':
- C_teq();
- break;
- case NOTEQUAL:
- C_tne();
- break;
- default:
- crash("(truthvalue)");
- /*NOTREACHED*/
- }
- }
- CodeSet(nd)
- register struct node *nd;
- {
- register struct type *tp = nd->nd_type;
- C_zer(tp->tp_size);
- nd = nd->nd_right;
- while( nd ) {
- assert(nd->nd_class == Link && nd->nd_symb == ',');
- CodeEl(nd->nd_left, tp);
- nd = nd->nd_right;
- }
- }
- CodeEl(nd, tp)
- register struct node *nd;
- register struct type *tp;
- {
- if( nd->nd_class == Link && nd->nd_symb == UPTO ) {
- Operands(nd->nd_left, nd->nd_right);
- C_loc(tp->tp_size); /* push size */
- C_cal("_bts"); /* library routine to fill set */
- C_asp(3 * word_size);
- }
- else {
- CodePExpr(nd);
- C_set(tp->tp_size);
- C_ior(tp->tp_size);
- }
- }
- struct type *
- CodeParameters(param, arg)
- struct paramlist *param;
- struct node *arg;
- {
- register struct type *tp, *left_tp, *last_tp = (struct type *) 0;
- struct node *left;
- struct desig ds;
- assert(param && arg);
- if( param->next )
- last_tp = CodeParameters(param->next, arg->nd_right);
- tp = TypeOfParam(param);
- left = arg->nd_left;
- left_tp = left->nd_type;
- if( IsConformantArray(tp) ) {
- if( last_tp != tp )
- /* push descriptors only once */
- CodeConfDescr(tp, left_tp);
- CodeDAddress(left);
- return tp;
- }
- if( IsVarParam(param) ) {
- CodeDAddress(left);
- return tp;
- }
- if( left_tp->tp_fund == T_STRINGCONST ) {
- CodePString(left, tp);
- return tp;
- }
- ds = InitDesig;
- CodeExpr(left, &ds, NO_LABEL);
- CodeValue(&ds, left_tp);
- RangeCheck(tp, left_tp);
- if( tp == real_type && BaseType(left_tp) == int_type )
- Int2Real(int_size);
- return tp;
- }
- CodeConfDescr(ftp, atp)
- register struct type *ftp, *atp;
- {
- struct type *elemtp = ftp->arr_elem;
- if( IsConformantArray(elemtp) )
- CodeConfDescr(elemtp, atp->arr_elem);
- if( atp->tp_fund == T_STRINGCONST ) {
- C_loc((arith) 1);
- C_loc(atp->tp_psize - 1);
- C_loc((arith) 1);
- }
- else if( IsConformantArray(atp) ) {
- if( atp->arr_sclevel < proclevel ) {
- C_lxa((arith) proclevel - atp->arr_sclevel);
- C_adp(atp->arr_cfdescr);
- }
- else
- C_lal(atp->arr_cfdescr);
- C_loi(3 * word_size);
- }
- else { /* normal array */
- assert(atp->tp_fund == T_ARRAY);
- assert(!IsConformantArray(atp));
- C_lae_dlb(atp->arr_ardescr, (arith) 0);
- C_loi( 3 * word_size);
- }
- }
- CodePString(nd, tp)
- struct node *nd;
- struct type *tp;
- {
- /* no null padding */
- C_lae_dlb(nd->nd_SLA, (arith) 0);
- C_loi(tp->tp_size);
- }
- CodeCall(nd)
- register struct node *nd;
- {
- /* Generate code for a procedure call. Checking of parameters
- and result is already done.
- */
- register struct node *left = nd->nd_left;
- register struct node *right = nd->nd_right;
- register struct def *df = left->nd_def;
- register struct type *result_tp;
- assert(IsProcCall(left));
- if( left->nd_type == std_type ) {
- CodeStd(nd);
- return;
- }
- if( right )
- (void) CodeParameters(ParamList(left->nd_type), right);
- assert(left->nd_class == Def);
- if( df->df_kind & D_ROUTINE ) {
- int level = df->df_scope->sc_level;
- if( level > 0 && !(df->df_flags & D_EXTERNAL) )
- C_lxl((arith) (proclevel - level));
- C_cal(df->prc_name);
- C_asp(left->nd_type->prc_nbpar);
- }
- else {
- label l1 = ++text_label;
- label l2 = ++text_label;
- assert(df->df_kind == D_VARIABLE);
- /* Push value of procedure/function parameter */
- CodePExpr(left);
- /* Test if value is a global or local procedure/function */
- C_exg(pointer_size);
- C_dup(pointer_size);
- C_zer(pointer_size);
- C_cmp();
- C_zeq(l1);
- /* At this point, on top of the stack the LB */
- C_exg(pointer_size);
- /* Now, the name of the procedure/function */
- C_cai();
- C_asp(pointer_size + left->nd_type->prc_nbpar);
- C_bra(l2);
- /* value is a global procedure/function */
- C_df_ilb(l1);
- C_asp(pointer_size); /* no LB needed */
- C_cai();
- C_asp(left->nd_type->prc_nbpar);
- C_df_ilb(l2);
- }
- if( result_tp = ResultType(left->nd_type) )
- C_lfr(result_tp->tp_size);
- }
- CodeStd(nd)
- struct node *nd;
- {
- register struct node *arg = nd->nd_right;
- register struct node *left = arg->nd_left;
- register struct type *tp = BaseType(left->nd_type);
- int req = nd->nd_left->nd_def->df_value.df_reqname;
- assert(arg->nd_class == Link && arg->nd_symb == ',');
- switch( req ) {
- case R_ABS:
- CodePExpr(left);
- if( tp == int_type )
- C_cal("_abi");
- else if ( tp == long_type )
- C_cal("_abl");
- else
- C_cal("_abr");
- C_asp(tp->tp_size);
- C_lfr(tp->tp_size);
- break;
- case R_SQR:
- CodePExpr(left);
- C_dup(tp->tp_size);
- if( tp == int_type || tp == long_type )
- C_mli(tp->tp_size);
- else
- C_mlf(real_size);
- break;
- case R_SIN:
- case R_COS:
- case R_EXP:
- case R_LN:
- case R_SQRT:
- case R_ARCTAN:
- assert(tp == real_type);
- CodePExpr(left);
- switch( req ) {
- case R_SIN:
- C_cal("_sin");
- break;
- case R_COS:
- C_cal("_cos");
- break;
- case R_EXP:
- C_cal("_exp");
- break;
- case R_LN:
- C_cal("_log");
- break;
- case R_SQRT:
- C_cal("_sqt");
- break;
- case R_ARCTAN:
- C_cal("_atn");
- break;
- default:
- crash("(CodeStd)");
- /*NOTREACHED*/
- }
- C_asp(real_size);
- C_lfr(real_size);
- break;
- case R_TRUNC:
- assert(tp == real_type);
- CodePExpr(left);
- Real2Int();
- break;
- case R_ROUND:
- assert(tp == real_type);
- CodePExpr(left);
- C_cal("_rnd");
- C_asp(real_size);
- C_lfr(real_size);
- Real2Int();
- break;
- case R_ORD:
- CodePExpr(left);
- break;
- case R_CHR:
- CodePExpr(left);
- genrck(char_type);
- break;
- case R_SUCC:
- case R_PRED:
- CodePExpr(left);
- C_loc((arith)1);
- if( tp == long_type) Int2Long();
- if( req == R_SUCC )
- C_adi(tp->tp_size);
- else
- C_sbi(tp->tp_size);
- if( bounded(left->nd_type) )
- genrck(left->nd_type);
- break;
- case R_ODD:
- CodePExpr(left);
- C_loc((arith) 1);
- if( tp == long_type ) Int2Long();
- C_and(tp->tp_size);
- if( tp == long_type ) Long2Int(); /* bool_size == int_size */
- break;
- case R_EOF:
- case R_EOLN:
- CodeDAddress(left);
- if( req == R_EOF )
- C_cal("_efl");
- else
- C_cal("_eln");
- C_asp(pointer_size);
- C_lfr(word_size);
- break;
- case R_REWRITE:
- case R_RESET:
- CodeDAddress(left);
- if( tp == text_type )
- C_loc((arith) 0);
- else
- C_loc(tp->next->tp_psize);
- /* ??? elements of packed size ??? */
- if( req == R_REWRITE )
- C_cal("_cre");
- else
- C_cal("_opn");
- C_asp(pointer_size + word_size);
- break;
- case R_PUT:
- case R_GET:
- CodeDAddress(left);
- if( req == R_PUT )
- C_cal("_put");
- else
- C_cal("_get");
- C_asp(pointer_size);
- break;
- case R_PAGE:
- CodeDAddress(left);
- C_cal("_pag");
- C_asp(pointer_size);
- break;
- case R_PACK: {
- label lba = tp->arr_ardescr;
- CodeDAddress(left);
- arg = arg->nd_right;
- left = arg->nd_left;
- CodePExpr(left);
- arg = arg->nd_right;
- left = arg->nd_left;
- CodeDAddress(left);
- C_lae_dlb(left->nd_type->arr_ardescr, (arith) 0);
- C_lae_dlb(lba, (arith) 0);
- C_cal("_pac");
- C_asp(4 * pointer_size + word_size);
- break;
- }
- case R_UNPACK: {
- /* change sequence of arguments of the library routine
- _unp to merge code of R_PACK and R_UNPACK.
- */
- label lba, lbz = tp->arr_ardescr;
- tp = tp->arr_elem;
- if (tp->tp_fund == T_SUBRANGE &&
- tp->sub_lb >= 0) {
- C_loc((arith) 1);
- }
- else C_loc((arith) 0);
- CodeDAddress(left);
- arg = arg->nd_right;
- left = arg->nd_left;
- CodeDAddress(left);
- lba = left->nd_type->arr_ardescr;
- arg = arg->nd_right;
- left = arg->nd_left;
- CodePExpr(left);
- C_lae_dlb(lbz, (arith) 0);
- C_lae_dlb(lba, (arith) 0);
- C_cal("_unp");
- C_asp(4 * pointer_size + 2 * word_size);
- break;
- }
- case R_NEW:
- case R_DISPOSE:
- CodeDAddress(left);
- C_loc(PointedtoType(tp)->tp_size);
- if( req == R_NEW )
- C_cal("_new");
- else
- C_cal("_dis");
- C_asp(pointer_size + word_size);
- break;
- case R_MARK:
- case R_RELEASE:
- CodeDAddress(left);
- if( req == R_MARK )
- C_cal("_sav");
- else
- C_cal("_rst");
- C_asp(pointer_size);
- break;
- case R_HALT:
- if( left )
- CodePExpr(left);
- else
- C_zer(int_size);
- C_cal("_hlt"); /* can't return */
- C_asp(int_size); /* help the optimizer(s) */
- break;
- default:
- crash("(CodeStd)");
- /*NOTREACHED*/
- }
- }
- Long2Int()
- {
- /* convert a long to integer */
- if (int_size == long_size) return;
- C_loc(long_size);
- C_loc(int_size);
- C_cii();
- }
- Int2Long()
- {
- /* convert integer to long */
- if (int_size == long_size) return;
- C_loc(int_size);
- C_loc(long_size);
- C_cii();
- }
- Int2Real(size) /* size is different for integers and longs */
- arith size;
- {
- /* convert integer to real */
- C_loc(size);
- C_loc(real_size);
- C_cif();
- }
- Real2Int()
- {
- /* convert real to integer */
- C_loc(real_size);
- C_loc(int_size);
- C_cfi();
- }
- RangeCheck(tpl, tpr)
- register struct type *tpl, *tpr;
- {
- /* Generate a range check if neccessary
- */
- arith llo, lhi, rlo, rhi;
- if( bounded(tpl) ) {
- /* in this case we might need a range check */
- if( !bounded(tpr) )
- /* yes, we need one */
- genrck(tpl);
- else {
- /* both types are restricted. check the bounds to see
- whether we need a range check. We don't need one
- if the range of values of the right hand side is a
- subset of the range of values of the left hand side.
- */
- getbounds(tpl, &llo, &lhi);
- getbounds(tpr, &rlo, &rhi);
- if( llo > rlo || lhi < rhi )
- genrck(tpl);
- }
- }
- }
- genrck(tp)
- register struct type *tp;
- {
- /* Generate a range check descriptor for type "tp" when
- necessary. Return its label.
- */
- arith lb, ub;
- register label o1;
- int newlabel = 0;
- if( options['R'] ) return;
- getbounds(tp, &lb, &ub);
- if( tp->tp_fund == T_SUBRANGE ) {
- if( !(o1 = tp->sub_rck) ) {
- tp->sub_rck = o1 = ++data_label;
- newlabel = 1;
- }
- }
- else if( !(o1 = tp->enm_rck) ) {
- tp->enm_rck = o1 = ++data_label;
- newlabel = 1;
- }
- if( newlabel ) {
- C_df_dlb(o1);
- C_rom_cst(lb);
- C_rom_cst(ub);
- }
- C_lae_dlb(o1, (arith) 0);
- C_rck(word_size);
- }
- CodePExpr(nd)
- register struct node *nd;
- {
- /* Generate code to push the value of the expression "nd"
- on the stack.
- */
- struct desig designator;
- struct type *tp = BaseType(nd->nd_type);
-
- designator = InitDesig;
- CodeExpr(nd, &designator, NO_LABEL);
- if( tp->tp_fund & (T_ARRAY | T_RECORD) )
- CodeAddress(&designator);
- else
- CodeValue(&designator, nd->nd_type);
- }
- CodeDAddress(nd)
- struct node *nd;
- {
- /* Generate code to push the address of the designator "nd"
- on the stack.
- */
- struct desig designator;
-
- designator = InitDesig;
- CodeDesig(nd, &designator);
- CodeAddress(&designator);
- }
- CodeDStore(nd)
- register struct node *nd;
- {
- /* Generate code to store the expression on the stack
- into the designator "nd".
- */
- struct desig designator;
-
- designator = InitDesig;
- CodeDesig(nd, &designator);
- CodeStore(&designator, nd->nd_type);
- }
- RegisterMessages(df)
- register struct def *df;
- {
- register struct type *tp;
- for( ; df; df = df->df_nextinscope ) {
- if( df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG) ) {
- /* Examine type and size
- */
- tp = BaseType(df->df_type);
- if( df->df_flags & D_VARPAR || tp->tp_fund & T_POINTER )
- C_ms_reg(df->var_off, pointer_size,
- reg_pointer, 0);
- else if( df->df_flags & D_LOOPVAR )
- C_ms_reg(df->var_off, tp->tp_size, reg_loop,2);
- else if( tp->tp_fund & T_NUMERIC )
- C_ms_reg(df->var_off, tp->tp_size,
- tp->tp_fund == T_REAL ? reg_float : reg_any, 0);
- }
- }
- }
|