123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254 |
- /*
- * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
- * See the copyright notice in the ACK home directory, in the file "Copyright".
- *
- * Author: Ceriel J.H. Jacobs
- */
- /* C O D E G E N E R A T I O N R O U T I N E S */
- /* $Id$ */
- /* Code generation for expressions and coercions
- */
- #include "debug.h"
- #include <em_arith.h>
- #include <em_label.h>
- #include <em_code.h>
- #include <em_abs.h>
- #include <assert.h>
- #include <alloc.h>
- #include "type.h"
- #include "LLlex.h"
- #include "def.h"
- #include "scope.h"
- #include "desig.h"
- #include "node.h"
- #include "Lpars.h"
- #include "standards.h"
- #include "walk.h"
- #include "bigresult.h"
- extern int proclevel;
- extern char options[];
- extern t_desig null_desig;
- int fp_used;
- CodeConst(cst, size)
- arith cst;
- int size;
- {
- /* Generate code to push constant "cst" with size "size"
- */
- if (size <= (int) word_size) {
- C_loc(cst);
- }
- else if (size == (int) dword_size) {
- C_ldc(cst);
- }
- else {
- crash("(CodeConst)");
- }
- }
- CodeString(nd)
- register t_node *nd;
- {
- if (nd->nd_type->tp_fund != T_STRING) {
- /* Character constant */
- CodeConst(nd->nd_INT, nd->nd_type->tp_size);
- return;
- }
- C_df_dlb(++data_label);
- C_rom_scon(nd->nd_STR, WA((arith)(nd->nd_SLE + 1)));
- c_lae_dlb(data_label);
- }
- CodeExpr(nd, ds, true_label, false_label)
- register t_node *nd;
- register t_desig *ds;
- label true_label, false_label;
- {
- register t_type *tp = nd->nd_type;
- DoLineno(nd);
- if (tp->tp_fund == T_REAL) fp_used = 1;
- switch(nd->nd_class) {
- case Def:
- if (nd->nd_def->df_kind & (D_PROCEDURE|D_PROCHEAD)) {
- C_lpi(nd->nd_def->prc_name);
- ds->dsg_kind = DSG_LOADED;
- break;
- }
- /* Fall through */
- case Link:
- case Arrsel:
- case Arrow:
- CodeDesig(nd, ds);
- break;
- case Oper:
- CodeOper(nd, true_label, false_label);
- ds->dsg_kind = DSG_LOADED;
- true_label = NO_LABEL;
- break;
- case Uoper:
- CodeUoper(nd);
- ds->dsg_kind = DSG_LOADED;
- break;
- case Value:
- switch(nd->nd_symb) {
- case REAL:
- C_df_dlb(++data_label);
- if (! nd->nd_RSTR) {
- static char buf[FLT_STRLEN];
- flt_flt2str(&nd->nd_RVAL, buf, FLT_STRLEN);
- C_rom_fcon(buf, tp->tp_size);
- }
- else C_rom_fcon(nd->nd_RSTR, tp->tp_size);
- c_lae_dlb(data_label);
- C_loi(tp->tp_size);
- break;
- case STRING:
- CodeString(nd);
- break;
- case INTEGER:
- CodeConst(nd->nd_INT, (int) (tp->tp_size));
- break;
- default:
- crash("Value error");
- }
- ds->dsg_kind = DSG_LOADED;
- break;
- case Call:
- CodeCall(nd);
- ds->dsg_kind = DSG_LOADED;
- break;
- case Set: {
- register unsigned i = (unsigned) (tp->tp_size) / (int) word_size;
- register arith *st = nd->nd_set + i;
- int null_set = 1;
- ds->dsg_kind = DSG_LOADED;
- for (; i; i--) {
- if (*--st != 0) null_set = 0;
- }
- if (! null_set) {
- i = (unsigned) (tp->tp_size) / (int) word_size;
- st = nd->nd_set + i;
- for (; i; i--) {
- C_loc(*--st);
- }
- }
- FreeSet(nd->nd_set);
- CodeSet(nd, null_set);
- }
- break;
- default:
- crash("(CodeExpr) bad node type");
- }
- if (true_label != NO_LABEL) {
- /* Only for boolean expressions
- */
- CodeValue(ds, tp);
- C_zne(true_label);
- c_bra(false_label);
- }
- }
- CodeCoercion(t1, t2)
- t_type *t1, *t2;
- {
- int fund1, fund2;
- int sz1 = t1->tp_size;
- int sz2;
- t1 = BaseType(t1);
- t2 = BaseType(t2);
- sz2 = t2->tp_size;
- switch(fund1 = t1->tp_fund) {
- case T_WORD:
- fund1 = T_INTEGER;
- break;
- case T_CHAR:
- case T_ENUMERATION:
- case T_CARDINAL:
- case T_INTORCARD:
- if (sz1 < (int) word_size) sz1 = word_size;
- /* fall through */
- case T_EQUAL:
- case T_POINTER:
- fund1 = T_CARDINAL;
- break;
- }
- switch(fund2 = t2->tp_fund) {
- case T_WORD:
- fund2 = T_INTEGER;
- break;
- case T_CHAR:
- case T_ENUMERATION:
- sz2 = word_size;
- /* fall through */
- case T_EQUAL:
- case T_POINTER:
- fund2 = T_CARDINAL;
- break;
- }
- switch(fund1) {
- case T_INTEGER:
- if (sz1 < (int) word_size) {
- c_loc(sz1);
- c_loc((int) word_size);
- C_cii();
- sz1 = word_size;
- }
- c_loc(sz1);
- c_loc(sz2);
- switch(fund2) {
- case T_REAL:
- C_cif();
- break;
- case T_INTEGER:
- C_cii();
- break;
- case T_CARDINAL:
- C_ciu();
- break;
- default:
- crash("Funny integer conversion");
- }
- break;
- case T_CARDINAL:
- case T_INTORCARD:
- c_loc(sz1);
- c_loc(sz2);
- switch(fund2) {
- case T_REAL:
- C_cuf();
- break;
- case T_CARDINAL:
- case T_INTORCARD:
- C_cuu();
- break;
- case T_INTEGER:
- C_cui();
- break;
- default:
- crash("Funny cardinal conversion");
- }
- break;
- case T_REAL:
- switch(fund2) {
- case T_REAL:
- c_loc(sz1);
- c_loc(sz2);
- C_cff();
- break;
- case T_INTEGER:
- c_loc(sz1);
- c_loc(sz2);
- C_cfi();
- break;
- case T_CARDINAL:
- if (! options['R']) {
- label lb = ++text_label;
- arith asz1 = sz1;
- C_dup(asz1);
- C_zrf(asz1);
- C_cmf(asz1);
- C_zge(lb);
- c_loc(ECONV);
- C_trp();
- def_ilb(lb);
- }
- c_loc(sz1);
- c_loc(sz2);
- C_cfu();
- break;
- default:
- crash("Funny REAL conversion");
- }
- break;
- }
- }
- CodeCall(nd)
- register t_node *nd;
- {
- /* Generate code for a procedure call. Checking of parameters
- and result is already done.
- */
- register t_node *left = nd->nd_LEFT;
- t_type *result_tp;
- int needs_fn;
- if (left->nd_type == std_type) {
- CodeStd(nd);
- return;
- }
- assert(IsProc(left));
- result_tp = ResultType(left->nd_type);
- #ifdef BIG_RESULT_ON_STACK
- if (result_tp && TooBigForReturnArea(result_tp)) {
- C_asp(-WA(result_tp->tp_size));
- }
- #endif
- if (nd->nd_RIGHT) {
- CodeParameters(ParamList(left->nd_type), nd->nd_RIGHT);
- }
- switch(left->nd_class) {
- case Def: {
- register t_def *df = left->nd_def;
- if (df->df_kind == D_CONST) {
- /* a procedure address */
- df = df->con_const.tk_data.tk_def;
- }
- if (df->df_kind & (D_PROCEDURE|D_PROCHEAD)) {
- int level = df->df_scope->sc_level;
- if (level > 0) {
- C_lxl((arith) (proclevel - level));
- }
- needs_fn = df->df_scope->sc_defmodule;
- C_cal(df->prc_name);
- break;
- }}
- /* Fall through */
- default:
- needs_fn = 1;
- CodePExpr(left);
- C_cai();
- }
- C_asp(left->nd_type->prc_nbpar);
- if (result_tp) {
- arith sz = WA(result_tp->tp_size);
- if (TooBigForReturnArea(result_tp)) {
- #ifndef BIG_RESULT_ON_STACK
- C_lfr(pointer_size);
- C_loi(sz);
- #endif
- }
- else C_lfr(sz);
- }
- DoFilename(needs_fn);
- DoLineno(nd);
- }
- CodeParameters(param, arg)
- t_param *param;
- register t_node *arg;
- {
- register t_type *tp;
- register t_type *arg_type;
- assert(param != 0 && arg != 0);
- if (param->par_next) {
- CodeParameters(param->par_next, arg->nd_RIGHT);
- }
- tp = TypeOfParam(param);
- arg = arg->nd_LEFT;
- arg_type = arg->nd_type;
- if (IsConformantArray(tp)) {
- register t_type *elem = tp->arr_elem;
- C_loc(tp->arr_elsize);
- if (IsConformantArray(arg_type)) {
- DoHIGH(arg->nd_def);
- if (elem->tp_size != arg_type->arr_elem->tp_size) {
- /* This can only happen if the formal type is
- ARRAY OF (WORD|BYTE)
- */
- C_loc(arg_type->arr_elem->tp_size);
- C_mlu(word_size);
- if (elem == word_type) {
- c_loc((int) word_size - 1);
- C_adu(word_size);
- c_loc((int) word_size - 1);
- C_and(word_size);
- }
- else {
- assert(elem == byte_type);
- }
- }
- }
- else if (arg->nd_symb == STRING) {
- c_loc((int) arg->nd_SLE - 1);
- }
- else if (elem == word_type) {
- C_loc((arg_type->tp_size+word_size-1) / word_size - 1);
- }
- else if (elem == byte_type) {
- C_loc(arg_type->tp_size - 1);
- }
- else {
- C_loc(arg_type->arr_high - arg_type->arr_low);
- }
- c_loc(0);
- }
- if (IsConformantArray(tp) || IsVarParam(param)) {
- if (arg->nd_symb == STRING) {
- CodeString(arg);
- }
- else switch(arg->nd_class) {
- case Arrsel:
- case Arrow:
- case Def:
- CodeDAddress(arg, IsVarParam(param));
- break;
- default:{
- arith tmp, TmpSpace();
- arith sz = WA(arg->nd_type->tp_size);
- CodePExpr(arg);
- tmp = TmpSpace(sz, arg->nd_type->tp_align);
- STL(tmp, sz);
- C_lal(tmp);
- }
- break;
- }
- return;
- }
- if (arg_type->tp_fund == T_STRING) {
- CodePString(arg, tp);
- return;
- }
- CodePExpr(arg);
- }
- CodePString(nd, tp)
- t_node *nd;
- t_type *tp;
- {
- arith szarg = WA(nd->nd_type->tp_size);
- register arith zersz = WA(tp->tp_size) - szarg;
- if (zersz) {
- /* null padding required */
- assert(zersz > 0);
- C_zer(zersz);
- }
- CodeString(nd); /* push address of string */
- C_loi(szarg);
- }
- static
- subu(sz)
- int sz;
- {
- if (! options['R']) {
- C_cal(sz == (int) word_size ? "subuchk" : "subulchk");
- }
- C_sbu((arith) sz);
- }
- static
- addu(sz)
- int sz;
- {
- if (! options['R']) {
- C_cal(sz == (int) word_size ? "adduchk" : "addulchk");
- }
- C_adu((arith)sz);
- }
- static int
- complex_lhs(nd)
- register t_node *nd;
- {
- switch(nd->nd_class) {
- case Value:
- case Name:
- case Set:
- case Def:
- return 0;
- case Select:
- return complex_lhs(nd->nd_NEXT);
- default:
- return 1;
- }
- }
- CodeStd(nd)
- t_node *nd;
- {
- register t_node *arg = nd->nd_RIGHT;
- register t_node *left = 0;
- register t_type *tp = 0;
- int std = nd->nd_LEFT->nd_def->df_value.df_stdname;
- if (arg) {
- left = arg->nd_LEFT;
- tp = BaseType(left->nd_type);
- arg = arg->nd_RIGHT;
- }
- switch(std) {
- case S_ORD:
- case S_VAL:
- CodePExpr(left);
- break;
- case S_ABS:
- CodePExpr(left);
- if (tp->tp_fund == T_INTEGER) {
- CAL((int)(tp->tp_size) == (int)int_size ? "absi" : "absl", (int)(tp->tp_size));
- }
- else if (tp->tp_fund == T_REAL) {
- CAL((int)(tp->tp_size) == (int)float_size ? "absf" : "absd", (int)(tp->tp_size));
- }
- C_lfr(tp->tp_size);
- break;
- case S_CAP:
- CodePExpr(left);
- C_cal("cap");
- break;
- case S_HIGH:
- assert(IsConformantArray(tp));
- DoHIGH(left->nd_def);
- break;
- case S_SIZE:
- case S_TSIZE:
- assert(IsConformantArray(tp));
- DoHIGH(left->nd_def);
- C_inc();
- C_loc(tp->arr_elem->tp_size);
- C_mlu(word_size);
- break;
- case S_ODD:
- CodePExpr(left);
- if ((int) tp->tp_size == (int) word_size) {
- c_loc(1);
- C_and(word_size);
- }
- else {
- assert(tp->tp_size == dword_size);
- C_ldc((arith) 1);
- C_and(dword_size);
- C_ior(word_size);
- }
- break;
- case S_ADR:
- CodeDAddress(left, 1);
- break;
- case S_DEC:
- case S_INC: {
- register arith size;
- int compl = complex_lhs(left);
- arith tmp = 0;
- size = left->nd_type->tp_size;
- if ((int) size < (int) word_size) size = word_size;
- if (compl) {
- tmp = NewPtr();
- CodeDAddress(left, 1);
- STL(tmp, pointer_size);
- LOL(tmp, pointer_size);
- C_loi(left->nd_type->tp_size);
- }
- else CodePExpr(left);
- CodeCoercion(left->nd_type, tp);
- if (arg) {
- CodePExpr(arg->nd_LEFT);
- CodeCoercion(arg->nd_LEFT->nd_type, tp);
- }
- else {
- c_loc(1);
- CodeCoercion(intorcard_type, tp);
- }
- if (std == S_DEC) {
- if (tp->tp_fund == T_INTEGER) C_sbi(size);
- else subu((int) size);
- }
- else {
- if (tp->tp_fund == T_INTEGER) C_adi(size);
- else addu((int) size);
- }
- if ((int) size == (int) word_size) {
- RangeCheck(left->nd_type, tp->tp_fund == T_INTEGER ?
- int_type : card_type);
- }
- if (compl) {
- LOL(tmp, pointer_size);
- C_sti(left->nd_type->tp_size);
- FreePtr(tmp);
- }
- else CodeDStore(left);
- break;
- }
- case S_HALT:
- C_cal("halt");
- break;
- case S_INCL:
- case S_EXCL: {
- int compl = complex_lhs(left);
- arith tmp = 0;
- if (compl) {
- tmp = NewPtr();
- CodeDAddress(left, 1);
- STL(tmp, pointer_size);
- LOL(tmp, pointer_size);
- C_loi(left->nd_type->tp_size);
- }
- else CodePExpr(left);
- CodePExpr(arg->nd_LEFT);
- C_loc(tp->set_low);
- C_sbi(word_size);
- C_set(tp->tp_size);
- if (std == S_INCL) {
- C_ior(tp->tp_size);
- }
- else {
- C_com(tp->tp_size);
- C_and(tp->tp_size);
- }
- if (compl) {
- LOL(tmp, pointer_size);
- C_sti(left->nd_type->tp_size);
- FreePtr(tmp);
- }
- else CodeDStore(left);
- break;
- }
- default:
- crash("(CodeStd)");
- }
- }
- int
- needs_rangecheck(tpl, tpr)
- register t_type *tpl, *tpr;
- {
- arith rlo, rhi;
- if (bounded(tpl)) {
- /* In this case we might need a range check.
- If both types are restricted. check the bounds
- to see wether 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.
- */
- if (bounded(tpr)) {
- getbounds(tpr, &rlo, &rhi);
- if (in_range(rlo, tpl) && in_range(rhi, tpl)) {
- return 0;
- }
- }
- return 1;
- }
- return 0;
- }
- RangeCheck(tpl, tpr)
- register t_type *tpl, *tpr;
- {
- /* Generate a range check if neccessary
- */
- arith rlo, rhi;
- if (options['R']) return;
- if (needs_rangecheck(tpl, tpr)) {
- genrck(tpl);
- return;
- }
- tpr = BaseType(tpr);
- if ((tpl->tp_fund == T_INTEGER && tpr->tp_fund == T_CARDINAL) ||
- (tpr->tp_fund == T_INTEGER && tpl->tp_fund == T_CARDINAL)) {
- label lb = ++text_label;
- C_dup(tpr->tp_size);
- C_zer(tpr->tp_size);
- C_cmi(tpr->tp_size);
- C_zge(lb);
- c_loc(ECONV);
- C_trp();
- def_ilb(lb);
- }
- }
- Operands(nd)
- register t_node *nd;
- {
- CodePExpr(nd->nd_LEFT);
- CodePExpr(nd->nd_RIGHT);
- DoLineno(nd);
- }
- CodeOper(expr, true_label, false_label)
- register t_node *expr; /* the expression tree itself */
- label true_label;
- label false_label; /* labels to jump to in logical expr's */
- {
- register t_node *leftop = expr->nd_LEFT;
- register t_node *rightop = expr->nd_RIGHT;
- int fund = expr->nd_type->tp_fund;
- arith size = expr->nd_type->tp_size;
- switch (expr->nd_symb) {
- case '+':
- Operands(expr);
- switch (fund) {
- case T_INTEGER:
- C_adi(size);
- break;
- case T_REAL:
- C_adf(size);
- break;
- case T_POINTER:
- case T_EQUAL:
- C_ads(rightop->nd_type->tp_size);
- break;
- case T_CARDINAL:
- case T_INTORCARD:
- addu((int) size);
- break;
- case T_SET:
- C_ior(size);
- break;
- default:
- crash("bad type +");
- }
- break;
- case '-':
- Operands(expr);
- switch (fund) {
- case T_INTEGER:
- C_sbi(size);
- break;
- case T_REAL:
- C_sbf(size);
- break;
- case T_POINTER:
- case T_EQUAL:
- if (rightop->nd_type == address_type) {
- C_sbs(size);
- break;
- }
- C_ngi(rightop->nd_type->tp_size);
- C_ads(rightop->nd_type->tp_size);
- break;
- case T_INTORCARD:
- case T_CARDINAL:
- subu((int) size);
- break;
- case T_SET:
- C_com(size);
- C_and(size);
- break;
- default:
- crash("bad type -");
- }
- break;
- case '*':
- Operands(expr);
- switch (fund) {
- case T_INTEGER:
- C_mli(size);
- break;
- case T_POINTER:
- case T_EQUAL:
- case T_CARDINAL:
- case T_INTORCARD:
- if (! options['R']) {
- C_cal((int)(size) <= (int)word_size ?
- "muluchk" :
- "mululchk");
- }
- C_mlu(size);
- break;
- case T_REAL:
- C_mlf(size);
- break;
- case T_SET:
- C_and(size);
- break;
- default:
- crash("bad type *");
- }
- break;
- case '/':
- Operands(expr);
- switch (fund) {
- case T_REAL:
- C_dvf(size);
- break;
- case T_SET:
- C_xor(size);
- break;
- default:
- crash("bad type /");
- }
- break;
- case DIV:
- Operands(expr);
- switch(fund) {
- case T_INTEGER:
- C_cal((int)(size) == (int)word_size
- ? "dvi"
- : "dvil");
- C_asp(2*size);
- C_lfr(size);
- break;
- case T_POINTER:
- case T_EQUAL:
- case T_CARDINAL:
- case T_INTORCARD:
- C_dvu(size);
- break;
- default:
- crash("bad type DIV");
- }
- break;
- case MOD:
- Operands(expr);
- switch(fund) {
- case T_INTEGER:
- C_cal((int)(size) == (int)word_size
- ? "rmi"
- : "rmil");
- C_asp(2*size);
- C_lfr(size);
- break;
- case T_POINTER:
- case T_EQUAL:
- case T_CARDINAL:
- case T_INTORCARD:
- C_rmu(size);
- break;
- default:
- crash("bad type MOD");
- }
- break;
- case '<':
- case LESSEQUAL:
- case '>':
- case GREATEREQUAL:
- case '=':
- case '#': {
- t_type *tp;
- Operands(expr);
- tp = BaseType(leftop->nd_type);
- if (tp->tp_fund == T_INTORCARD) tp = BaseType(rightop->nd_type);
- size = tp->tp_size;
- switch (tp->tp_fund) {
- case T_INTEGER:
- C_cmi(size);
- break;
- case T_POINTER:
- case T_HIDDEN:
- case T_EQUAL:
- C_cmp();
- break;
- case T_CARDINAL:
- case T_INTORCARD:
- C_cmu(size);
- break;
- case T_ENUMERATION:
- case T_CHAR:
- C_cmu(word_size);
- break;
- case T_REAL:
- C_cmf(size);
- break;
- case T_SET:
- if (expr->nd_symb == GREATEREQUAL) {
- /* A >= B is the same as A equals A + B
- */
- C_dup(size << 1);
- C_asp(size);
- C_ior(size);
- expr->nd_symb = '=';
- }
- else if (expr->nd_symb == LESSEQUAL) {
- /* A <= B is the same as A - B = {}
- */
- C_com(size);
- C_and(size);
- C_zer(size);
- expr->nd_symb = '=';
- }
- C_cms(size);
- break;
- default:
- crash("bad type COMPARE");
- }
- if (true_label != NO_LABEL) {
- compare(expr->nd_symb, true_label);
- c_bra(false_label);
- break;
- }
- truthvalue(expr->nd_symb);
- break;
- }
- case IN: {
- /* In this case, evaluate right hand side first! The
- INN instruction expects the bit number on top of the
- stack
- */
- label l_toolarge = NO_LABEL, l_cont = NO_LABEL;
- t_type *ltp = leftop->nd_type;
- if (leftop->nd_symb == COERCION) {
- /* Could be coercion to word_type. */
- ltp = leftop->nd_RIGHT->nd_type;
- }
- if (leftop->nd_class == Value) {
- if (! in_range(leftop->nd_INT, ElementType(rightop->nd_type))) {
- if (true_label != NO_LABEL) {
- c_bra(false_label);
- }
- else c_loc(0);
- break;
- }
- CodePExpr(rightop);
- C_loc(leftop->nd_INT - rightop->nd_type->set_low);
- }
- else {
- CodePExpr(rightop);
- CodePExpr(leftop);
- C_loc(rightop->nd_type->set_low);
- C_sbu(word_size);
- if (needs_rangecheck(ElementType(rightop->nd_type), ltp)) {
- l_toolarge = ++text_label;
- C_dup(word_size);
- C_loc(rightop->nd_type->tp_size*8);
- C_cmu(word_size);
- C_zge(l_toolarge);
- }
- }
- C_inn(rightop->nd_type->tp_size);
- if (true_label != NO_LABEL) {
- C_zne(true_label);
- c_bra(false_label);
- }
- else {
- l_cont = ++text_label;
- c_bra(l_cont);
- }
- if (l_toolarge != NO_LABEL) {
- def_ilb(l_toolarge);
- C_asp(word_size+rightop->nd_type->tp_size);
- if (true_label != NO_LABEL) {
- c_bra(false_label);
- }
- else c_loc(0);
- }
- if (l_cont != NO_LABEL) {
- def_ilb(l_cont);
- }
- break;
- }
- case OR:
- case AND: {
- label l_maybe = ++text_label, l_end = NO_LABEL;
- t_desig Des;
- Des = null_desig;
- if (true_label == NO_LABEL) {
- true_label = ++text_label;
- false_label = ++text_label;
- l_end = ++text_label;
- }
- if (expr->nd_symb == OR) {
- CodeExpr(leftop, &Des, true_label, l_maybe);
- }
- else CodeExpr(leftop, &Des, l_maybe, false_label);
- def_ilb(l_maybe);
- Des = null_desig;
- CodeExpr(rightop, &Des, true_label, false_label);
- if (l_end != NO_LABEL) {
- def_ilb(true_label);
- c_loc(1);
- c_bra(l_end);
- def_ilb(false_label);
- c_loc(0);
- def_ilb(l_end);
- }
- break;
- }
- default:
- crash("(CodeOper) Bad operator");
- }
- }
- /* compare() serves as an auxiliary function of CodeOper */
- compare(relop, lbl)
- int relop;
- register label lbl;
- {
- switch (relop) {
- case '<':
- C_zlt(lbl);
- break;
- case LESSEQUAL:
- C_zle(lbl);
- break;
- case '>':
- C_zgt(lbl);
- break;
- case GREATEREQUAL:
- C_zge(lbl);
- break;
- case '=':
- C_zeq(lbl);
- break;
- case '#':
- C_zne(lbl);
- break;
- default:
- crash("(compare)");
- }
- }
- /* truthvalue() serves as an auxiliary function of CodeOper */
- truthvalue(relop)
- int 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 '#':
- C_tne();
- break;
- default:
- crash("(truthvalue)");
- }
- }
- CodeUoper(nd)
- register t_node *nd;
- {
- register t_type *tp = nd->nd_type;
- CodePExpr(nd->nd_RIGHT);
- switch(nd->nd_symb) {
- case NOT:
- C_teq();
- break;
- case '-':
- switch(tp->tp_fund) {
- case T_INTEGER:
- case T_INTORCARD:
- C_ngi(tp->tp_size);
- break;
- case T_REAL:
- C_ngf(tp->tp_size);
- break;
- default:
- crash("Bad operand to unary -");
- }
- break;
- case COERCION:
- CodeCoercion(nd->nd_RIGHT->nd_type, tp);
- RangeCheck(tp, nd->nd_RIGHT->nd_type);
- break;
- case CAST:
- break;
- default:
- crash("Bad unary operator");
- }
- }
- CodeSet(nd, null_set)
- register t_node *nd;
- {
- register t_type *tp = nd->nd_type;
- nd = nd->nd_NEXT;
- while (nd) {
- assert(nd->nd_class == Link && nd->nd_symb == ',');
- if (nd->nd_LEFT) {
- CodeEl(nd->nd_LEFT, tp, null_set);
- null_set = 0;
- }
- nd = nd->nd_RIGHT;
- }
- if (null_set) C_zer(tp->tp_size);
- }
- CodeEl(nd, tp, null_set)
- register t_node *nd;
- register t_type *tp;
- {
- register t_type *eltype = ElementType(tp);
- if (nd->nd_class == Link && nd->nd_symb == UPTO) {
- if (null_set) C_zer(tp->tp_size);
- C_loc(tp->set_low);
- C_loc(tp->tp_size); /* push size */
- if (eltype->tp_fund == T_SUBRANGE) {
- C_loc(eltype->sub_ub);
- }
- else C_loc(eltype->enm_ncst - 1);
- Operands(nd);
- CAL("LtoUset", 5 * (int) word_size);
- /* library routine to fill set */
- }
- else {
- CodePExpr(nd);
- C_loc(tp->set_low);
- C_sbi(word_size);
- C_set(tp->tp_size);
- if (! null_set) C_ior(tp->tp_size);
- }
- }
- CodePExpr(nd)
- register t_node *nd;
- {
- /* Generate code to push the value of the expression "nd"
- on the stack.
- */
- t_desig designator;
- designator = null_desig;
- CodeExpr(nd, &designator, NO_LABEL, NO_LABEL);
- CodeValue(&designator, nd->nd_type);
- }
- CodeDAddress(nd, chk_controlvar)
- t_node *nd;
- {
- /* Generate code to push the address of the designator "nd"
- on the stack.
- */
- t_desig designator;
- int chkptr;
- designator = null_desig;
- if (chk_controlvar) ChkForFOR(nd);
- CodeDesig(nd, &designator);
- chkptr = designator.dsg_kind==DSG_PLOADED ||
- designator.dsg_kind==DSG_PFIXED;
- CodeAddress(&designator);
- /* Generate dummy use of pointer, to get possible error message
- as soon as possible
- */
- if (chkptr && ! options['R']) {
- C_dup(pointer_size);
- C_loi((arith) 1);
- C_asp(word_size);
- }
- }
- CodeDStore(nd)
- register t_node *nd;
- {
- /* Generate code to store the expression on the stack into the
- designator "nd".
- */
- t_desig designator;
- designator = null_desig;
- ChkForFOR(nd);
- CodeDesig(nd, &designator);
- CodeStore(&designator, nd->nd_type);
- }
- DoHIGH(df)
- register t_def *df;
- {
- /* Get the high index of a conformant array, indicated by "nd".
- The high index is the second field in the descriptor of
- the array, so it is easily found.
- */
- register arith highoff;
- assert(df->df_kind == D_VARIABLE);
- assert(IsConformantArray(df->df_type));
- highoff = df->var_off /* base address and descriptor */
- + word_size + pointer_size;
- /* skip base and first field of
- descriptor
- */
- if (df->df_scope->sc_level < proclevel) {
- C_lxa((arith) (proclevel - df->df_scope->sc_level));
- C_lof(highoff);
- }
- else C_lol(highoff);
- }
- #ifdef SQUEEZE
- c_bra(l)
- label l;
- {
- C_bra((label) l);
- }
- c_loc(n)
- {
- C_loc((arith) n);
- }
- c_lae_dlb(l)
- label l;
- {
- C_lae_dlb(l, (arith) 0);
- }
- CAL(name, ssp)
- char *name;
- int ssp;
- {
- C_cal(name);
- C_asp((arith) ssp);
- }
- #endif
|