user/a60/doeval.c

   1 /*
   2  * Copyright (C) 1991,1992 Erik Schoenfelder (schoenfr@ibr.cs.tu-bs.de)
   3  *
   4  * This file is part of NASE A60.
   5  *
   6  * NASE A60 is free software; you can redistribute it and/or modify it
   7  * under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation; either version 2, or (at your option)
   9  * any later version.
  10  *
  11  * NASE A60 is distributed in the hope that it will be useful, but
  12  * WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14  * General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU General Public License
  17  * along with NASE A60; see the file COPYING.  If not, write to the Free
  18  * Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19  *
  20  * doeval.c:                                            oct '90
  21  *
  22  * Erik Schoenfelder (schoenfr@ibr.cs.tu-bs.de)
  23  *
  24  * here is some code about runtime evaluation; it is mixed with
  25  * eval.c and used from run.c
  26  */
  27
  28 #include "comm.h"
  29 #include "a60.h"
  30 #include "util.h"
  31 #include "conv.h"
  32 #include "run.h"
  33 #include "eval.h"
  34
  35
  36 /*
  37  * evaluate a switch expression.
  38  */
  39
  40 static void
  41 do_eval_switchexpr (sym, ex)
  42 SYMTAB *sym;
  43 EXPR *ex;
  44 {
  45         long idx = 0;
  46         SWACT *swact;
  47         EVALELM ev, *evp;
  48
  49 #ifdef DEBUG
  50         if (do_debug)
  51                 printf ("** do_eval_switchexpr: sym is `%s' ...\n", sym->name);
  52 #endif /* DEBUG */
  53
  54         if (sym->tag == s_byname)
  55                 xabort ("INTERNAL: do_eval_switchexpr: s_byname");
  56
  57         swact = get_swact (sym);
  58         if (! swact) {
  59                 a60_error (ex->source, ex->lineno,
  60                            "uninitialized switch list (symbol is `%s').\n",
  61                            sym->name);
  62                 xabort ("runtime error");
  63         }
  64
  65         /* now eval the index: */
  66         do_eval_expr (ex);
  67         DO_DEREF(ex->source, ex->lineno);
  68         ev = * POP_EVALST;
  69         if (ev.tag == ev_ival)
  70                 idx = ev.u.ival;
  71         else if (ev.tag == ev_rval)
  72                 idx = RVAL2IVAL (ev.u.rval);
  73         else {
  74                 a60_error (ex->source, ex->lineno,
  75    "subscript of designational expression must be of numerical type.\n");
  76                 a60_error (ex->source, ex->lineno,
  77                            "(but the type is `%s').\n",
  78                            eval_tag_name [ev.tag]);
  79                 xabort ("runtime error");
  80         }
  81
  82 #ifdef DEBUG
  83         if (do_debug)
  84                 printf ("** do_eval_switchexpr: idx is %ld.\n", idx);
  85 #endif /* DEBUG */
  86
  87         if (idx < 1 || idx > swact->nelm) {
  88                 /*
  89                  * an undefined design. expr. leads to a dummy
  90                  */
  91
  92                 /* +++++ add runtime warning +++++ */
  93
  94 #ifdef DEBUG
  95                 if (do_debug)
  96                         printf ("** index out of range: dummy.\n");
  97 #endif /* DEBUG */
  98
  99                 evp = PUSH_EVALST(ex->source, ex->lineno, ev_label);
 100                 evp->u.sym = (SYMTAB *) 0;
 101         }
 102         else {
 103                 evp = PUSH_EVALST(ex->source, ex->lineno, ev_label);
 104                 /* ***** 16 bit idx ***** */
 105                 evp->u.sym = swact->targs [(int) idx - 1];
 106         }
 107 }
 108
 109
 110 static void
 111 do_eval_arrval (lhelm)
 112 LHELM *lhelm;
 113 {
 114         SYMTAB *sym = lhelm->sym;
 115         MINDEX *mindex;
 116         CBLOCK *cb;
 117         ACTIV *act;
 118         ACT_BOUND *bound;
 119         EVALELM *ev;
 120         long idx = 0;
 121 #ifdef MEMORY_STATISTICS
 122         DO_STACK_STAT;
 123 #endif
 124
 125         mindex = lhelm->mindex;
 126         if (! mindex)
 127                 xabort ("INTERNAL: do_eval_arrval: no mindex");
 128
 129         while (sym->tag == s_byname) {
 130                 CBLOCK *cb = act_cblock;
 131                 ACTIV *act;
 132 #ifdef DEBUG
 133                 if (do_debug)
 134                         printf ("* do_eval_arrval: sym is `%s'...\n",
 135                                 sym->name);
 136 #endif /* DEBUG */
 137                 while (cb->block != sym->block)
 138                         cb = cb->next;
 139                 act = cb->activ + sym->actidx;
 140                 if (act->data->u.pexpr.expr->tag != e_symbol)
 141                         xabort ("INTERNAL: do_eval_arrval: no symbol");
 142                 sym = act->data->u.pexpr.expr->u.lhelm->sym;
 143         }
 144
 145 #ifdef DEBUG
 146         if (do_debug)
 147                 printf ("* do_eval_arrval: sym is `%s' !\n", sym->name);
 148 #endif /* DEBUG */
 149
 150         if (sym->type == ty_switch) {
 151                 /*
 152                  * got you: this is parsed as an array access, but
 153                  * actual ans des-expression.
 154                  * its a bad hack - yeh.
 155                  */
 156
 157 #ifdef DEBUG
 158                 if (do_debug)
 159                         printf ("** do_eval_arrval: is a switch ...\n");
 160 #endif /* DEBUG */
 161
 162                 do_eval_switchexpr (sym, mindex->expr);
 163                 return;
 164         }
 165
 166         if (! TIS_ARR(sym->type)) {
 167                 a60_error (lhelm->source, lhelm->lineno,
 168                            "not an array: `%s'\n", sym->name);
 169                 xabort ("runtime error");
 170         }
 171
 172         cb = act_cblock;
 173         while (cb->block != sym->block)
 174                 cb = cb->next;
 175         act = cb->activ + sym->actidx;
 176         /*
 177          * this can happen, if the array declaration is interrupted by
 178          * an goto :-)
 179          */
 180         if (! act || ! act->arract) {
 181                 a60_error (lhelm->source, lhelm->lineno,
 182                            "uninitialized array\n");
 183                 xabort ("runtime error");
 184         }
 185
 186         bound = act->arract->act_bound;
 187
 188         while (mindex) {
 189                 do_eval_expr (mindex->expr);
 190                 DO_DEREF(mindex->expr->source, mindex->expr->lineno);
 191                 ev = POP_EVALST;
 192
 193                 if (ev->tag == ev_rval) {
 194                         ev->tag = ev_ival;
 195                         ev->u.ival = RVAL2IVAL(ev->u.rval);
 196                 }
 197                 else if (ev->tag != ev_ival) {
 198                         a60_error (ev->source, ev->lineno,
 199                    "array index must be of numerical type (found `%s')\n",
 200                                    eval_tag_name[ev->tag]);
 201                         xabort ("runtime error");
 202                 }
 203
 204                 if (ev->u.ival < bound->from
 205                     || ev->u.ival > bound->til) {
 206                         a60_error (ev->source, ev->lineno,
 207         "index not in bound; index is %ld, bounds are [%ld : %ld]\n",
 208                                    ev->u.ival, bound->from, bound->til);
 209                         xabort ("runtime error");
 210                 }
 211
 212                 idx = idx + (ev->u.ival - bound->from) * bound->mpl;
 213
 214                 mindex = mindex->next;
 215                 bound = bound->next;
 216         }
 217
 218 #ifdef DEBUG
 219         if (do_debug)
 220                 printf ("* do_eval_arrval: idx is %ld.\n", idx);
 221 #endif /* DEBUG */
 222
 223         push_valaddr (lhelm->source, lhelm->lineno, sym, idx);
 224 }
 225
 226
 227
 228 void
 229 do_push_lhelm (lhelm)
 230 LHELM *lhelm;
 231 {
 232         SYMTAB *sym = lhelm->sym;
 233
 234
 235         if (lhelm->mindex) {
 236                 do_eval_arrval (lhelm);
 237                 return;
 238         }
 239
 240 #ifdef DEBUG
 241         if (do_debug)
 242                 printf ("* do_push_lhelm: sym is `%s'...\n", sym->name);
 243 #endif /* DEBUG */
 244
 245         while (sym->tag == s_byname) {
 246                 CBLOCK *cb = act_cblock;
 247                 ACTIV *act;
 248                 ENUM expr_tag tag;
 249                 while (cb->block != sym->block)
 250                         cb = cb->next;
 251                 act = cb->activ + sym->actidx;
 252                 tag = act->data->u.pexpr.expr->tag;
 253                 if (tag != e_symbol && tag != e_fcall) {
 254                         a60_error (lhelm->source, lhelm->lineno,
 255                                 "no valid lefthand type (type is `%s')\n",
 256                                  sym->name);
 257                         xabort ("runtime error");
 258                 }
 259                 if (act->data->u.pexpr.expr->u.lhelm->mindex) {
 260                         do_eval_arrval (act->data->u.pexpr.expr->u.lhelm);
 261                         return;
 262                 }
 263                 sym = act->data->u.pexpr.expr->u.lhelm->sym;
 264         }
 265
 266
 267 #ifdef DEBUG
 268         if (do_debug)
 269                 printf ("* do_push_lhelm: sym is `%s' !\n", sym->name);
 270 #endif /* DEBUG */
 271
 272         if (! TIS_SVALT(sym->type)) {
 273                 a60_error (lhelm->source, lhelm->lineno,
 274                    "illegal lefthand side (type is `%s')\n",
 275                            type_tag_name[sym->type]);
 276                 xabort ("runtime error");
 277         }
 278
 279         push_valaddr (lhelm->source, lhelm->lineno, sym, (long) 0);
 280 }
 281
 282
 283
 284 void
 285 do_eval_lhelm (lhelm)
 286 LHELM *lhelm;
 287 {
 288         SYMTAB *sym = lhelm->sym;
 289         ENUM expr_tag tag;
 290 #ifdef MEMORY_STATISTICS
 291         DO_STACK_STAT;
 292 #endif
 293
 294         if (lhelm->mindex) {
 295                 do_eval_arrval (lhelm);
 296                 return;
 297         }
 298
 299 #ifdef DEBUG
 300         if (do_debug)
 301                 printf ("* do_eval_lhelm: sym is `%s'...\n", sym->name);
 302 #endif /* DEBUG */
 303
 304         if (sym->tag == s_byname) {
 305                 CBLOCK *cb = act_cblock;
 306                 ACTIV *act;
 307                 while (cb->block != sym->block)
 308                         cb = cb->next;
 309                 act = cb->activ + sym->actidx;
 310                 tag = act->data->u.pexpr.expr->tag;
 311                 if (tag != e_symbol) {
 312                         do_eval_pexpr (& act->data->u.pexpr);
 313                         return;
 314                 }
 315                 do_eval_pexpr (& act->data->u.pexpr);
 316                 return;
 317         }
 318
 319 #ifdef DEBUG
 320         if (do_debug)
 321                 printf ("* do_eval_lhelm: sym is `%s' !\n", sym->name);
 322 #endif /* DEBUG */
 323
 324         if (TIS_BASET(sym->type) || TIS_FUNC(sym->type)) {
 325                 push_valaddr (lhelm->source, lhelm->lineno, sym, (long) 0);
 326         }
 327         else if (TIS_SPECT(sym->type)) {
 328                 push_spec (lhelm->source, lhelm->lineno, sym);
 329         }
 330         else if (TIS_ARR(sym->type)) {
 331                 push_spec (lhelm->source, lhelm->lineno, sym);
 332         }
 333         else
 334                 a60_error (lhelm->source, lhelm->lineno,
 335                    "INTERNAL: do_eval_lhelm: bad sym type `%s'\n",
 336                            sym_tag_name[sym->type]);
 337 }
 338
 339
 340 void
 341 do_eval_expr (ex)
 342 EXPR *ex;
 343 {
 344         ENUM expr_tag tag = ex->tag;
 345         EVALELM *ev, top_ev;
 346         SYMTAB *sym;
 347 #ifdef MEMORY_STATISTICS
 348         DO_STACK_STAT;
 349 #endif
 350
 351 #ifdef DEBUG
 352         if (do_debug)
 353                 printf ("** do_eval_expr: have here a `%s' (type is `%s').\n",
 354                         expr_tag_name [tag], type_tag_name [ex->type]);
 355 #endif /* DEBUG */
 356
 357         if (tag == e_switch) {
 358                 sym = ex->u.eswitch->sym;
 359                 while (sym->tag == s_byname) {
 360
 361                         while (sym->tag == s_byname) {
 362                                 CBLOCK *cb = act_cblock;
 363                                 ACTIV *act;
 364 #ifdef DEBUG
 365                                 if (do_debug)
 366                                         printf (
 367                         "* do_eval_expr: switch sym is `%s'...\n",
 368                                                 sym->name);
 369 #endif /* DEBUG */
 370                                 while (cb->block != sym->block)
 371                                         cb = cb->next;
 372                                 act = cb->activ + sym->actidx;
 373                                 if (act->data->u.pexpr.expr->tag != e_symbol)
 374                                         xabort (
 375                                 "INTERNAL: do_eval_expr: switch: no symbol");
 376                                 sym = act->data->u.pexpr.expr->u.lhelm->sym;
 377 #ifdef DEBUG
 378                                 if (do_debug)
 379                                         printf (
 380                         "* do_eval_expr: now it is  `%s'...\n",
 381                                                 sym->name);
 382 #endif /* DEBUG */
 383                         }
 384                 }
 385                 do_eval_switchexpr (sym, ex->u.eswitch->expr);
 386                 return;
 387         }
 388         else if (tag == e_label) {
 389                 sym = ex->u.label;
 390                 while (sym->tag == s_byname) {
 391                         DATA *data;
 392
 393 #ifdef DEBUG
 394                         if (do_debug)
 395                                 printf ("** label with s_byname (%s)...\n",
 396                                         sym->name);
 397 #endif /* DEBUG */
 398
 399                         data = get_sym_data (sym);
 400                         do_eval_pexpr (&(data->u.pexpr));
 401                         return;
 402                 }
 403                 ev = PUSH_EVALST(ex->source, ex->lineno, ev_label);
 404                 ev->u.sym = sym;
 405         }
 406         else if (tag == e_symbol) {
 407                 /*
 408                  * hmmm - may be its a numerical expression or it is a
 409                  * designational expression...
 410                  */
 411                 do_eval_lhelm (ex->u.lhelm);
 412         }
 413         else if (tag == e_fcall) {
 414                 if (trace)
 415                         printf ("line %d: executing func call (`%s')\n",
 416                                 ex->lineno, ex->u.lhelm->sym->name);
 417
 418                 sym = ex->u.lhelm->sym;
 419                 while ((TIS_PROC(sym->type) || sym->type == ty_unknown)
 420                        && sym->tag == s_byname) {
 421                         DATA *data;
 422                         EVALELM ev;
 423 #ifdef DEBUG
 424                         if (do_debug)
 425                                 printf ("** call with func parm (%s):\n",
 426                                         sym->name);
 427 #endif /* DEBUG */
 428                         data = get_sym_data (sym);
 429                         push_spec_pexpr (&(data->u.pexpr));
 430                         ev = * POP_EVALST;
 431                         sym = ev.u.sym;
 432 #ifdef DEBUG
 433                         if (do_debug)
 434                                 printf ("   -> now it is func parm (%s).\n",
 435                                         sym->name);
 436 #endif /* DEBUG */
 437                 }
 438
 439                 if (! TIS_FUNC(sym->type) && sym->tag == s_defined) {
 440                         a60_error (ex->source, ex->lineno,
 441                    "must return a value (`%s')\n",
 442                                    ex->u.lhelm->sym->name);
 443                         xabort ("runtime error");
 444                 }
 445
 446                 exec_fcall (ex->source, ex->lineno,
 447                             sym, ex->u.lhelm->u.fcall);
 448         }
 449         else if (tag == e_ival) {
 450                 ev = PUSH_EVALST(ex->source, ex->lineno, ev_ival);
 451                 ev->u.ival = ex->u.ival;
 452         }
 453         else if (tag == e_rval) {
 454                 ev = PUSH_EVALST(ex->source, ex->lineno, ev_rval);
 455                 ev->u.rval = ex->u.rval;
 456         }
 457         else if (tag == e_bool) {
 458                 ev = PUSH_EVALST(ex->source, ex->lineno, ev_bool);
 459                 ev->u.bool = ex->u.bool;
 460         }
 461         else if (tag == e_string) {
 462                 ev = PUSH_EVALST(ex->source, ex->lineno, ev_string);
 463                 ev->u.string = ex->u.string;
 464         }
 465         else if (EIS_UNEXP(tag)) {
 466                 do_eval_expr (ex->u.expr[0]);
 467                 DO_DEREF(ex->source, ex->lineno);
 468                 do_unop (tag);
 469         }
 470         else if (EIS_BINEXP(tag)) {
 471                 do_eval_expr (ex->u.expr[1]);
 472                 DO_DEREF(ex->source, ex->lineno);
 473                 do_eval_expr (ex->u.expr[0]);
 474                 DO_DEREF(ex->source, ex->lineno);
 475                 do_binop (tag);
 476         }
 477         else if (tag == e_condexpr) {
 478                 do_eval_expr (ex->u.expr[0]);
 479                 DO_DEREF(ex->source, ex->lineno);
 480                 top_ev = * POP_EVALST;
 481                 if (top_ev.tag != ev_bool)
 482                         a60_error ("INTERNAL", 0, "INTERNAL: No Bool!\n");
 483                 if (top_ev.u.bool)
 484                         do_eval_expr (ex->u.expr[1]);
 485                 else
 486                         do_eval_expr (ex->u.expr[2]);
 487         }
 488         else if (EIS_NOP(tag)) {
 489                 do_eval_expr (ex->u.expr[0]);
 490         }
 491         else {
 492                 a60_error (ex->source, ex->lineno,
 493                            "INTERNAL: do_eval_expr: unknown expr_tag `%s'\n",
 494                            expr_tag_name[tag]);
 495                 xabort ("INTERNAL error");
 496         }
 497 }
 498
 499
 500 void
 501 do_eval_pexpr (pex)
 502 PEXPR *pex;
 503 {
 504         if (pex->cblock)
 505                 push_cblock (pex->cblock);
 506
 507         do_eval_expr (pex->expr);
 508
 509         if (pex->cblock)
 510                 pop_cblock ();
 511
 512 }
 513
 514 /* end of doeval.c */