user/a60/bltin.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  * bltin.c:                                     sept '90
  21  *
  22  * Erik Schoenfelder (schoenfr@ibr.cs.tu-bs.de)
  23  */
  24
  25 #include "comm.h"
  26 #include "a60.h"
  27 #include "symtab.h"
  28 #include "util.h"
  29 #include "run.h"
  30 #include "conv.h"
  31 #include "bltin.h"
  32 #include "eval.h"
  33
  34
  35 #define NOT_FOR_MKC_C
  36 /*
  37  * include common stuff:
  38  */
  39 #include "a60-mkc.inc"
  40
  41 /* and clear the flag: */
  42 #undef NOT_FOR_MKC_C
  43
  44
  45 /*
  46  * the predefind functions (procs):
  47  */
  48
  49 /* ARGSUSED */
  50 static void
  51 bltin_pi (sym, nparm)
  52 SYMTAB *sym;
  53 int nparm;
  54 {
  55         CBLOCK *cb;
  56         DATA *data;
  57
  58 #ifdef DEBUG
  59         if (do_debug)
  60                 printf ("** builtin PI called.\n");
  61 #endif /* DEBUG */
  62
  63         for (cb=act_cblock; cb && cb->block != sym->block; cb=cb->next)
  64                 continue;
  65
  66         if (!cb || ! cb->block || ! cb->activ)
  67                 xabort ("INTERNAL: bltin_pi: no block or activation");
  68
  69         data = (cb->activ)[sym->actidx].data;
  70
  71         data->u.val->u.rval = M_PI;
  72         data->u.val->valid = 1;
  73 }
  74
  75
  76 /* ARGSUSED */
  77 static void
  78 bltin_rand (sym, nparm)
  79 SYMTAB *sym;
  80 int nparm;
  81 {
  82         CBLOCK *cb;
  83         DATA *data;
  84
  85 #ifdef DEBUG
  86         if (do_debug)
  87                 printf ("** builtin rand called.\n");
  88 #endif /* DEBUG */
  89
  90         for (cb=act_cblock; cb && cb->block != sym->block; cb=cb->next)
  91                 continue;
  92
  93         if (!cb || ! cb->block || ! cb->activ)
  94                 xabort ("INTERNAL: bltin_rand: no block or activation");
  95
  96         data = (cb->activ)[sym->actidx].data;
  97
  98         data->u.val->u.rval = b_rand ();
  99         data->u.val->valid = 1;
 100 }
 101
 102
 103 /*
 104  * hmmm - the vprint proc; this one with a variable number of arguments.
 105  * we'll see
 106  */
 107
 108 /* ARGSUSED */
 109 static void
 110 bltin_vprint (sym, nparm)
 111 SYMTAB *sym;
 112 int nparm;
 113 {
 114         CBLOCK *cb;
 115         DATA *data;
 116         EVALELM ev;
 117         int i;
 118
 119 #ifdef DEBUG
 120         if (do_debug)
 121                 printf ("** builtin vprint called (%d arguments).\n", nparm);
 122 #endif /* DEBUG */
 123
 124         cb = act_cblock;
 125
 126         if (!cb || ! cb->block || ! cb->activ) {
 127                 /* no activation means no parameter -> newline only. */
 128                 printf ("\n");
 129                 return;
 130         }
 131
 132         for (i=0; i<nparm; i++) {
 133                 data = (cb->activ)[i].data;
 134                 do_eval_pexpr (& data->u.pexpr);
 135                 DO_DEREF(data->u.pexpr.expr->source,
 136                           data->u.pexpr.expr->lineno);
 137                 ev = * POP_EVALST;
 138
 139                 if (ev.tag == ev_ival) {
 140                         printf ("  %15ld ", ev.u.ival);
 141                 }
 142                 else if (ev.tag == ev_rval) {
 143 #ifdef sun
 144                         /*
 145                          * printf ("%g",  - 0.0) gives: -0
 146                          * may be a ``Klassiker'' by sun only...
 147                          * i like to prevent this:
 148                          */
 149                         if (ev.u.rval == 0.0)
 150                                 ev.u.rval = (int) ev.u.rval;
 151 #endif
 152                         printf ("  %15.7e ", ev.u.rval);
 153                 }
 154                 else if (ev.tag == ev_string) {
 155                         printf ("%s", ev.u.string);
 156                 }
 157                 else if (ev.tag == ev_bool) {
 158                         printf (" %s ", (ev.u.bool) ? "T" : "F");
 159                 }
 160                 else {
 161                         a60_error (ev.source, ev.lineno,
 162                            "vprint cannot handle parameter of type `%s'\n",
 163                                    eval_tag_name[ev.tag]);
 164                         xabort ("runtime error");
 165                 }
 166                 fflush (stdout);
 167         }
 168
 169         printf ("\n");
 170         fflush (stdout);
 171 }
 172
 173
 174 /* ARGSUSED */
 175 static void
 176 bltin_outreal (sym, nparm)
 177 SYMTAB *sym;
 178 int nparm;
 179 {
 180         CBLOCK *cb;
 181         DATA *chandata, *valdata;
 182         long chan;
 183         double val;
 184
 185 #ifdef DEBUG
 186         if (do_debug)
 187                 printf ("** builtin outreal called.\n");
 188 #endif /* DEBUG */
 189
 190         cb = act_cblock;
 191
 192         if (!cb || ! cb->block || ! cb->activ)
 193                 xabort ("INTERNAL: bltin_outreal: no block or activation");
 194
 195         chandata = (cb->activ)[0].data;
 196         valdata = (cb->activ)[1].data;
 197
 198         chan = chandata->u.val->u.ival;
 199         val = valdata->u.val->u.rval;
 200
 201 #ifdef DEBUG
 202         if (do_debug)
 203                 printf ("** bltin_outreal: chan %d; value %g\n",
 204                         chan, val);
 205 #endif /* DEBUG */
 206
 207         b_outreal (chan, val);
 208 }
 209
 210
 211 /* ARGSUSED */
 212 static void
 213 bltin_outinteger (sym, nparm)
 214 SYMTAB *sym;
 215 int nparm;
 216 {
 217         CBLOCK *cb;
 218         long chan, val;
 219
 220 #ifdef DEBUG
 221         if (do_debug)
 222                 printf ("** builtin outinteger called.\n");
 223 #endif /* DEBUG */
 224
 225         cb = act_cblock;
 226
 227         if (!cb || ! cb->block || ! cb->activ)
 228                 xabort ("INTERNAL: bltin_outinteger: no block or activation");
 229
 230         chan = (cb->activ)[0].data->u.val->u.ival;
 231         val = (cb->activ)[1].data->u.val->u.ival;
 232
 233 #ifdef DEBUG
 234         if (do_debug)
 235                 printf ("** bltin_outinteger: chan %ld; value %ld\n",
 236                         chan, val);
 237 #endif /* DEBUG */
 238
 239         b_outint (chan, val);
 240 }
 241
 242
 243 /* ARGSUSED */
 244 static void
 245 bltin_outstring (sym, nparm)
 246 SYMTAB *sym;
 247 int nparm;
 248 {
 249         CBLOCK *cb;
 250         long chan;
 251         PEXPR *pexpr;
 252         EVALELM ev;
 253         char *val;
 254
 255 #ifdef DEBUG
 256         if (do_debug)
 257                 printf ("** builtin outstring called.\n");
 258 #endif /* DEBUG */
 259
 260         cb = act_cblock;
 261
 262         if (!cb || ! cb->block || ! cb->activ)
 263                 xabort ("INTERNAL: bltin_outstring: no block or activation");
 264
 265         chan = (cb->activ)[0].data->u.val->u.ival;
 266         pexpr = & (cb->activ)[1].data->u.pexpr;
 267         do_eval_pexpr (pexpr);
 268         ev = * POP_EVALST;
 269         if (ev.tag != ev_string) {
 270                 a60_error (ev.source, ev.lineno,
 271            "actual parameter does not match formal\n");
 272                 xabort ("runtime error");
 273         }
 274         val = ev.u.string;
 275
 276 #ifdef DEBUG
 277         if (do_debug)
 278                 printf ("** bltin_outstring: chan %ld; value %s\n",
 279                         chan, (val) ? val : "");
 280 #endif /* DEBUG */
 281         b_outstr (chan, val);
 282 }
 283
 284
 285 /* ARGSUSED */
 286 static void
 287 bltin_outsymbol (sym, nparm)
 288 SYMTAB *sym;
 289 int nparm;
 290 {
 291         CBLOCK *cb;
 292         PEXPR *pexpr;
 293         EVALELM ev;
 294         long chan, idx;
 295         char *val;
 296
 297 #ifdef DEBUG
 298         if (do_debug)
 299                 printf ("** builtin outsymbol called.\n");
 300 #endif /* DEBUG */
 301
 302         cb = act_cblock;
 303
 304         if (!cb || ! cb->block || ! cb->activ)
 305                 xabort ("INTERNAL: bltin_outsymbol: no block or activation");
 306
 307         chan = (cb->activ)[0].data->u.val->u.ival;
 308         idx = (cb->activ)[2].data->u.val->u.ival;
 309
 310         pexpr = & (cb->activ)[1].data->u.pexpr;
 311         do_eval_pexpr (pexpr);
 312         ev = * POP_EVALST;
 313         if (ev.tag != ev_string) {
 314                 a60_error (ev.source, ev.lineno,
 315            "actual parameter does not match formal\n");
 316                 xabort ("runtime error");
 317         }
 318         val = ev.u.string;
 319
 320 #ifdef DEBUG
 321         if (do_debug)
 322                 printf ("** bltin_outsymbol: chan %ld; str %s; idx %ld\n",
 323                         chan, (val) ? val : "", idx);
 324 #endif /* DEBUG */
 325
 326         b_outsym (chan, val, idx);
 327 }
 328
 329
 330 /* ARGSUSED */
 331 static void
 332 bltin_insymbol (sym, nparm)
 333 SYMTAB *sym;
 334 int nparm;
 335 {
 336         CBLOCK *cb;
 337         PEXPR *pexpr;
 338         EVALELM ev, *evp;
 339         long chan, val;
 340         char *str;
 341
 342 #ifdef DEBUG
 343         if (do_debug)
 344                 printf ("** builtin insymbol called.\n");
 345 #endif /* DEBUG */
 346
 347         cb = act_cblock;
 348
 349         if (!cb || ! cb->block || ! cb->activ)
 350                 xabort ("INTERNAL: bltin_insymbol: no block or activation");
 351
 352         chan = (cb->activ)[0].data->u.val->u.ival;
 353
 354         pexpr = & (cb->activ)[1].data->u.pexpr;
 355         do_eval_pexpr (pexpr);
 356         ev = * POP_EVALST;
 357         if (ev.tag != ev_string) {
 358                 a60_error (ev.source, ev.lineno,
 359            "actual parameter does not match formal\n");
 360                 xabort ("runtime error");
 361         }
 362         str = ev.u.string;
 363
 364 #ifdef DEBUG
 365         if (do_debug)
 366                 printf ("** bltin_insymbol: chan %ld; str %s:\n",
 367                         chan, (str) ? str : "");
 368 #endif /* DEBUG */
 369
 370         if (run_with_xa60) {
 371                 xabort ("xa60: insymbol: cannot send input - sorry.");
 372                 /* not reached */
 373                 return;
 374         }
 375
 376         val = b_insym (chan, str);
 377
 378 #ifdef DEBUG
 379         if (do_debug)
 380                 printf ("** bltin_insymbol: val %ld\n", val);
 381 #endif /* DEBUG */
 382
 383         pexpr = & (cb->activ)[2].data->u.pexpr;
 384         do_eval_pexpr (pexpr);
 385
 386         evp = PUSH_EVALST ("internal", 0, ev_ival);
 387         evp->u.ival = val;
 388
 389         assign_vals (0);
 390 }
 391
 392
 393 /* ARGSUSED */
 394 static void
 395 bltin_inreal (sym, nparm)
 396 SYMTAB *sym;
 397 int nparm;
 398 {
 399         CBLOCK *cb;
 400         PEXPR *pexpr;
 401         EVALELM *evp;
 402         long chan;
 403         double val;
 404
 405 #ifdef DEBUG
 406         if (do_debug)
 407                 printf ("** builtin inreal called.\n");
 408 #endif /* DEBUG */
 409
 410         cb = act_cblock;
 411
 412         if (!cb || ! cb->block || ! cb->activ)
 413                 xabort ("INTERNAL: bltin_inreal: no block or activation");
 414
 415         chan = (cb->activ)[0].data->u.val->u.ival;
 416 #ifdef DEBUG
 417         if (do_debug)
 418                 printf ("** bltin_inreal: chan %ld;\n", chan);
 419 #endif /* DEBUG */
 420
 421         if (run_with_xa60) {
 422                 xabort ("xa60: inreal: cannot send input - sorry.");
 423                 /* not reached */
 424                 return;
 425         }
 426
 427         val = b_inreal (chan);
 428
 429 #ifdef DEBUG
 430         if (do_debug)
 431                 printf ("** bltin_inreal: val %e\n", val);
 432 #endif /* DEBUG */
 433
 434         pexpr = & (cb->activ)[1].data->u.pexpr;
 435         do_eval_pexpr (pexpr);
 436
 437         evp = PUSH_EVALST ("internal", 0, ev_rval);
 438         evp->u.rval = val;
 439
 440         assign_vals (0);
 441 }
 442
 443
 444 /* ARGSUSED */
 445 static void
 446 bltin_length (sym, nparm)
 447 SYMTAB *sym;
 448 int nparm;
 449 {
 450         CBLOCK *cb;
 451         PEXPR *pexpr;
 452         EVALELM ev;
 453         DATA *data;
 454         long len;
 455         char *val;
 456
 457 #ifdef DEBUG
 458         if (do_debug)
 459                 printf ("** builtin length called.\n");
 460 #endif /* DEBUG */
 461
 462         cb = act_cblock;
 463
 464         if (!cb || ! cb->block || ! cb->activ)
 465                 xabort ("INTERNAL: bltin_length: no block or activation");
 466
 467         pexpr = & (cb->activ)[0].data->u.pexpr;
 468         do_eval_pexpr (pexpr);
 469         ev = * POP_EVALST;
 470         if (ev.tag != ev_string) {
 471                 a60_error (ev.source, ev.lineno,
 472            "actual parameter does not match formal\n");
 473                 xabort ("runtime error");
 474         }
 475         val = ev.u.string;
 476
 477 #ifdef DEBUG
 478         if (do_debug)
 479                 printf ("** bltin_length: string `%s'\n", (val) ? val : "");
 480 #endif /* DEBUG */
 481
 482         len = b_length (val);
 483
 484         /*
 485          * now assign the return value:
 486          */
 487
 488         for (cb=act_cblock; cb && cb->block != sym->block; cb=cb->next)
 489                 continue;
 490
 491         if (!cb || ! cb->block || ! cb->activ)
 492                 xabort ("INTERNAL: bltin_length: no block or activation");
 493
 494         data = (cb->activ)[sym->actidx].data;
 495
 496         data->u.val->u.ival = len;
 497         data->u.val->valid = 1;
 498 }
 499
 500
 501 /* ARGSUSED */
 502 static void
 503 bltin_print (sym, nparm)
 504 SYMTAB *sym;
 505 int nparm;
 506 {
 507         CBLOCK *cb;
 508         long f1, f2;
 509         double val;
 510
 511 #ifdef DEBUG
 512         if (do_debug)
 513                 printf ("** builtin print called.\n");
 514 #endif /* DEBUG */
 515
 516         cb = act_cblock;
 517
 518         if (!cb || ! cb->block || ! cb->activ)
 519                 xabort ("INTERNAL: bltin_print: no block or activation");
 520
 521         val = (cb->activ)[0].data->u.val->u.rval;
 522         f1 = (cb->activ)[1].data->u.val->u.ival;
 523         f2 = (cb->activ)[2].data->u.val->u.ival;
 524
 525 #ifdef DEBUG
 526         if (do_debug)
 527                 printf ("** bltin_print: val %g; format: %ld  %ld\n",
 528                         val, f1, f2);
 529 #endif /* DEBUG */
 530
 531         b_print (val, f1, f2);
 532 }
 533
 534
 535
 536
 537
 538 /* ARGSUSED */
 539 static void
 540 bltin_write (sym, nparm)
 541 SYMTAB *sym;
 542 int nparm;
 543 {
 544         CBLOCK *cb;
 545         PEXPR *pexpr;
 546         EVALELM ev;
 547         char *val;
 548
 549 #ifdef DEBUG
 550         if (do_debug)
 551                 printf ("** builtin write called.\n");
 552 #endif /* DEBUG */
 553
 554         cb = act_cblock;
 555
 556         if (!cb || ! cb->block || ! cb->activ)
 557                 xabort ("INTERNAL: bltin_write: no block or activation");
 558
 559         pexpr = & (cb->activ)[0].data->u.pexpr;
 560         do_eval_pexpr (pexpr);
 561         ev = * POP_EVALST;
 562         if (ev.tag != ev_string) {
 563                 a60_error (ev.source, ev.lineno,
 564            "actual parameter does not match formal\n");
 565                 xabort ("runtime error");
 566         }
 567         val = ev.u.string;
 568
 569         printf ("%s", val);
 570         fflush (stdout);
 571 }
 572
 573
 574 /*
 575  * get the parameter of the function and the data space for the
 576  * return value.
 577  */
 578
 579 static void
 580 get_val_and_rdata (sym, val_data, ret_data)
 581 SYMTAB *sym;
 582 DATA **val_data, **ret_data;
 583 {
 584         CBLOCK *cb;
 585         DATA *data;
 586
 587 #ifdef DEBUG
 588         if (do_debug)
 589                 printf ("** builtin func `%s' called.\n", sym->name);
 590 #endif /* DEBUG */
 591
 592         cb = act_cblock;
 593
 594         if (! cb || ! cb->block || ! cb->activ)
 595                 xabort ("INTERNAL: get_val_and_rdata: no block or activation");
 596
 597         data = (cb->activ)[0].data;
 598         * val_data = data;
 599
 600         /*
 601          * now get the return data space:
 602          */
 603
 604         for (cb=act_cblock; cb && cb->block != sym->block; cb=cb->next)
 605                 continue;
 606
 607         if (! cb || ! cb->block || ! cb->activ)
 608                 xabort ("INTERNAL: get_val_and_rdata: no block or activation");
 609
 610         data = (cb->activ)[sym->actidx].data;
 611
 612         * ret_data = data;
 613 }
 614
 615
 616 /*
 617  * builtin real functions:
 618  */
 619
 620 #define BLTIN_MATH_HEAD(b) \
 621 /* ARGSUSED */ \
 622 static void \
 623 b (sym, nparm) \
 624 SYMTAB *sym; \
 625 int nparm; \
 626 { \
 627         DATA *val_data, *ret_data; \
 628         double x; \
 629  \
 630         get_val_and_rdata (sym, &val_data, &ret_data); \
 631         x = val_data->u.val->u.rval;
 632
 633 #define BLTIN_MATH_TAIL \
 634         ret_data->u.val->u.rval = x; \
 635         ret_data->u.val->valid = 1; \
 636 }
 637
 638
 639
 640 /*
 641  * and now the bltin functions:
 642  */
 643
 644 BLTIN_MATH_HEAD(bltin_abs)
 645         if (x < 0.0)
 646                 x = -x;
 647 BLTIN_MATH_TAIL
 648
 649 BLTIN_MATH_HEAD(bltin_sqrt)
 650         if (x < 0.0) {
 651                 a60_error (sym->source, sym->lineno,
 652                            "argument of sqrt is negative (%g).\n", x);
 653                            xabort ("runtime error");
 654         }
 655         x = sqrt (x);
 656 BLTIN_MATH_TAIL
 657
 658 BLTIN_MATH_HEAD(bltin_sin)
 659         x = sin (x);
 660 BLTIN_MATH_TAIL
 661
 662 BLTIN_MATH_HEAD(bltin_cos)
 663         x = cos (x);
 664 BLTIN_MATH_TAIL
 665
 666 BLTIN_MATH_HEAD(bltin_arctan)
 667         x = atan (x);
 668 BLTIN_MATH_TAIL
 669
 670 BLTIN_MATH_HEAD(bltin_ln)
 671         if (x < 0.0) {
 672                 a60_error (sym->source, sym->lineno,
 673                            "argument of log is negative (%g).\n", x);
 674                            xabort ("runtime error");
 675         }
 676         x = log (x);
 677 BLTIN_MATH_TAIL
 678
 679 BLTIN_MATH_HEAD(bltin_exp)
 680         x = exp (x);
 681 BLTIN_MATH_TAIL
 682
 683
 684 /*
 685  * sign:
 686  */
 687
 688 /* ARGSUSED */
 689 static void
 690 bltin_sign (sym, nparm)
 691 SYMTAB *sym;
 692 int nparm;
 693 {
 694         DATA *val_data, *ret_data; double x;
 695
 696 #ifdef DEBUG
 697         if (do_debug) printf ("* bltin sign called ...\n");
 698 #endif /* DEBUG */
 699         get_val_and_rdata (sym, &val_data, &ret_data);
 700         x = val_data->u.val->u.rval;
 701
 702         ret_data->u.val->u.ival = b_sign (x);
 703         ret_data->u.val->valid = 1;
 704 }
 705
 706
 707 /*
 708  * entier:
 709  */
 710
 711 /* ARGSUSED */
 712 static void
 713 bltin_entier (sym, nparm)
 714 SYMTAB *sym;
 715 int nparm;
 716 {
 717         DATA *val_data, *ret_data; double x;
 718
 719 #ifdef DEBUG
 720         if (do_debug) printf ("* bltin entier called ...\n");
 721 #endif /* DEBUG */
 722
 723         get_val_and_rdata (sym, &val_data, &ret_data);
 724         x = val_data->u.val->u.rval;
 725
 726         ret_data->u.val->u.ival = b_entier (x);
 727         ret_data->u.val->valid = 1;
 728 }
 729
 730
 731
 732 /*
 733  * init the predefined symbols;
 734  */
 735
 736 static SYMTAB *
 737 init_new_symbol (name, type, bltin)
 738 char *name;
 739 ENUM type_tag type;
 740 void (* bltin) ();
 741 {
 742         PPROC *new = TALLOC (PPROC);
 743         SYMTAB *psym = new_symbol (name, type, s_defined);
 744         psym->source = "<internal>";
 745         psym->lineno = 0;
 746         examine_and_append_symtab (current_scope->symtab, psym);
 747         psym->block = current_scope->block;
 748
 749         open_new_scope ();
 750         psym->u.pproc = new;
 751         psym->u.pproc->nparm = 0;
 752         psym->u.pproc->block = current_scope->block;
 753
 754         psym->u.pproc->bltin = bltin;
 755         close_current_scope ();
 756
 757         return psym;
 758 }
 759
 760 static SYMTAB *
 761 init_parmsym (name, type, tag)
 762 char *name;
 763 ENUM type_tag type;
 764 ENUM sym_tag tag;
 765 {
 766         SYMTAB *new = new_symbol (name, type, tag);
 767
 768         return new;
 769 }
 770
 771
 772 /*
 773  * initialize builtin function `PI':
 774  *
 775  *      'real' 'procedure' PI;
 776  *              PI := 3.14;
 777  *
 778  */
 779
 780 static void
 781 init_pi ()
 782 {
 783         SYMTAB *sym;
 784
 785         sym = init_new_symbol ("PI", ty_real_proc, bltin_pi);
 786         sym->u.pproc->block->nact = 0;
 787 }
 788
 789
 790 /*
 791  * initialize build in function `rand':
 792  *
 793  *      'real' 'procedure' rand;
 794  *              'code';
 795  *
 796  */
 797
 798 static void
 799 init_rand ()
 800 {
 801         SYMTAB *sym;
 802
 803         sym = init_new_symbol ("rand", ty_real_proc, bltin_rand);
 804         sym->u.pproc->block->nact = 0;
 805 }
 806
 807
 808 /*
 809  * initialize builtin function `print':
 810  *
 811  *      'procedure' printf (....);
 812  *              'code';
 813  */
 814
 815 static void
 816 init_vprint ()
 817 {
 818         SYMTAB *sym;
 819
 820         sym = init_new_symbol ("vprint", ty_proc, bltin_vprint);
 821         sym->u.pproc->nparm = -1;
 822 }
 823
 824
 825 /*
 826  * initialize builtin function `outreal':
 827  *
 828  *      'procedure' outreal (channel, value);
 829  *      'value' channel, value;
 830  *      'integer' channel;
 831  *      'real' value;
 832  *              'code';
 833  *
 834  */
 835
 836 static void
 837 init_outreal ()
 838 {
 839         SYMTAB *sym, *parmsym;
 840
 841         sym = init_new_symbol ("outreal", ty_proc, bltin_outreal);
 842         parmsym = init_parmsym ("channel", ty_integer, s_byvalue);
 843         parmsym->block = sym->u.pproc->block;
 844         parmsym->next = init_parmsym ("source", ty_real, s_byvalue);
 845         parmsym->next->block = sym->u.pproc->block;
 846         set_actidx (parmsym);
 847         sym->u.pproc->block->symtab = parmsym;
 848         sym->u.pproc->block->nact = 2;
 849         sym->u.pproc->nparm = 2;
 850 }
 851
 852
 853 /*
 854  * initialize builtin function `outinteger':
 855  *
 856  *      'procedure' outinteger (channel, value);
 857  *      'value' channel, value;
 858  *      'integer' channel, value;
 859  *              'code';
 860  *
 861  */
 862
 863 static void
 864 init_outinteger ()
 865 {
 866         SYMTAB *sym, *parmsym;
 867
 868         sym = init_new_symbol ("outinteger", ty_proc, bltin_outinteger);
 869         parmsym = init_parmsym ("channel", ty_integer, s_byvalue);
 870         parmsym->block = sym->u.pproc->block;
 871         parmsym->next = init_parmsym ("source", ty_integer, s_byvalue);
 872         parmsym->next->block = sym->u.pproc->block;
 873         set_actidx (parmsym);
 874         sym->u.pproc->block->symtab = parmsym;
 875         sym->u.pproc->block->nact = 2;
 876         sym->u.pproc->nparm = 2;
 877 }
 878
 879
 880 /*
 881  * initialize builtin function `outstring':
 882  *
 883  *      'procedure' outstring (channel, value);
 884  *      'value' channel;
 885  *      'integer' channel;
 886  *      'string' value;
 887  *              'code';
 888  *
 889  */
 890
 891 static void
 892 init_outstring ()
 893 {
 894         SYMTAB *sym, *parmsym;
 895
 896         sym = init_new_symbol ("outstring", ty_proc, bltin_outstring);
 897         parmsym = init_parmsym ("channel", ty_integer, s_byvalue);
 898         parmsym->block = sym->u.pproc->block;
 899         parmsym->next = init_parmsym ("source", ty_string, s_byname);
 900         parmsym->next->block = sym->u.pproc->block;
 901         set_actidx (parmsym);
 902         sym->u.pproc->block->symtab = parmsym;
 903         sym->u.pproc->block->nact = 2;
 904         sym->u.pproc->nparm = 2;
 905 }
 906
 907
 908 /*
 909  * initialize builtin function `outsymbol':
 910  *
 911  *      'procedure' outsymbol (channel, string, source);
 912  *      'value' channel, source;
 913  *      'integer' channel, source;
 914  *      'string' string;
 915  *              'code';
 916  *
 917  */
 918
 919 static void
 920 init_outsymbol ()
 921 {
 922         SYMTAB *sym, *parmsym;
 923
 924         sym = init_new_symbol ("outsymbol", ty_proc, bltin_outsymbol);
 925         parmsym = init_parmsym ("channel", ty_integer, s_byvalue);
 926         parmsym->block = sym->u.pproc->block;
 927         parmsym->next = init_parmsym ("string", ty_string, s_byname);
 928         parmsym->next->block = sym->u.pproc->block;
 929         parmsym->next->next = init_parmsym ("source", ty_integer, s_byvalue);
 930         parmsym->next->next->block = sym->u.pproc->block;
 931         set_actidx (parmsym);
 932         sym->u.pproc->block->symtab = parmsym;
 933         sym->u.pproc->block->nact = 3;
 934         sym->u.pproc->nparm = 3;
 935 }
 936
 937
 938 /*
 939  * initialize builtin fucntion `insymbol':
 940  *
 941  *      'integer' 'procedure' insymbol (channel, string, value);
 942  *      'value' channel;
 943  *      'integer' channel, value;
 944  *      'string' string;
 945  *              'code';
 946  *
 947  */
 948
 949 static void
 950 init_insymbol ()
 951 {
 952         SYMTAB *sym, *parmsym;
 953
 954         sym = init_new_symbol ("insymbol", ty_proc, bltin_insymbol);
 955         parmsym = init_parmsym ("channel", ty_integer, s_byvalue);
 956         parmsym->block = sym->u.pproc->block;
 957         parmsym->next = init_parmsym ("string", ty_string, s_byname);
 958         parmsym->next->block = sym->u.pproc->block;
 959         parmsym->next->next = init_parmsym ("value", ty_integer, s_byname);
 960         parmsym->next->next->block = sym->u.pproc->block;
 961         set_actidx (parmsym);
 962         sym->u.pproc->block->symtab = parmsym;
 963         sym->u.pproc->block->nact = 3;
 964         sym->u.pproc->nparm = 3;
 965 }
 966
 967
 968 /*
 969  * initialize builtin fucntion `inreal':
 970  *
 971  *      'procedure' inreal (channel, value);
 972  *      'value' channel;
 973  *      'integer' channel;
 974  *      'real' value;
 975  *              'code';
 976  *
 977  */
 978
 979 static void
 980 init_inreal ()
 981 {
 982         SYMTAB *sym, *parmsym;
 983
 984         sym = init_new_symbol ("inreal", ty_proc, bltin_inreal);
 985         parmsym = init_parmsym ("channel", ty_integer, s_byvalue);
 986         parmsym->block = sym->u.pproc->block;
 987         parmsym->next = init_parmsym ("value", ty_real, s_byname);
 988         parmsym->next->block = sym->u.pproc->block;
 989         set_actidx (parmsym);
 990         sym->u.pproc->block->symtab = parmsym;
 991         sym->u.pproc->block->nact = 2;
 992         sym->u.pproc->nparm = 2;
 993 }
 994
 995
 996 /*
 997  * initialize builtin function `print':
 998  *
 999  *      'procedure' print (value, f1, f2);
1000  *      'value' value, f1, f2;
1001  *      'real' value;
1002  *      'integer' f1, f2;
1003  *              'code';
1004  */
1005
1006 static void
1007 init_print ()
1008 {
1009         SYMTAB *sym, *parmsym;
1010
1011         sym = init_new_symbol ("print", ty_proc, bltin_print);
1012         parmsym = init_parmsym ("value", ty_real, s_byvalue);
1013         parmsym->block = sym->u.pproc->block;
1014         parmsym->next = init_parmsym ("f1", ty_integer, s_byvalue);
1015         parmsym->next->block = sym->u.pproc->block;
1016         parmsym->next->next = init_parmsym ("f2", ty_integer, s_byvalue);
1017         parmsym->next->next->block = sym->u.pproc->block;
1018         set_actidx (parmsym);
1019         sym->u.pproc->block->symtab = parmsym;
1020         sym->u.pproc->block->nact = 3;
1021         sym->u.pproc->nparm = 3;
1022 }
1023
1024
1025 /*
1026  * initialize builtin function `length':
1027  *
1028  *      'integer' 'procedure' length (string);
1029  *      'string' string;
1030  *              'code';
1031  *
1032  */
1033
1034 static void
1035 init_length ()
1036 {
1037         SYMTAB *sym, *parmsym;
1038
1039         sym = init_new_symbol ("length", ty_int_proc, bltin_length);
1040         parmsym = init_parmsym ("string", ty_string, s_byname);
1041         parmsym->block = sym->u.pproc->block;
1042         set_actidx (parmsym);
1043         sym->u.pproc->block->symtab = parmsym;
1044         sym->u.pproc->block->nact = 1;
1045         sym->u.pproc->nparm = 1;
1046 }
1047
1048
1049 /*
1050  * initialize build-in function `write':
1051  *
1052  *      'integer' 'procedure' write (string);
1053  *      'string' string;
1054  *              'code';
1055  */
1056
1057 static void
1058 init_write ()
1059 {
1060         SYMTAB *sym, *parmsym;
1061
1062         sym = init_new_symbol ("write", ty_proc, bltin_write);
1063         parmsym = init_parmsym ("string", ty_string, s_byname);
1064         parmsym->block = sym->u.pproc->block;
1065         set_actidx (parmsym);
1066         sym->u.pproc->block->symtab = parmsym;
1067         sym->u.pproc->block->nact = 1;
1068         sym->u.pproc->nparm = 1;
1069 }
1070
1071
1072 /*
1073  * initialize the bltin simple functions:
1074  *
1075  *      <value> 'procedure' func (x);
1076  *      'value' x;
1077  *      'real' x;
1078  *              'code';
1079  *
1080  * this is for abs(), sign(), sqrt(), sin(), cos(), arctan(),
1081  * ln(), exp();
1082  */
1083
1084 #define INIT_SFUNC(f,s,rty,ty,b) \
1085 static void \
1086 f () \
1087 { \
1088         SYMTAB *sym, *parmsym; \
1089  \
1090         sym = init_new_symbol (s, rty, b); \
1091         parmsym = init_parmsym ("value", ty, s_byvalue); \
1092         parmsym->block = sym->u.pproc->block; \
1093         set_actidx (parmsym); \
1094         sym->u.pproc->block->symtab = parmsym; \
1095         sym->u.pproc->block->nact = 1; \
1096         sym->u.pproc->nparm = 1; \
1097 }
1098
1099 INIT_SFUNC(init_entier, "entier", ty_int_proc, ty_real, bltin_entier)
1100 INIT_SFUNC(init_abs, "abs", ty_real_proc, ty_real, bltin_abs)
1101 INIT_SFUNC(init_sign, "sign", ty_int_proc, ty_real, bltin_sign)
1102 INIT_SFUNC(init_sqrt, "sqrt", ty_real_proc, ty_real, bltin_sqrt)
1103 INIT_SFUNC(init_sin, "sin", ty_real_proc, ty_real, bltin_sin)
1104 INIT_SFUNC(init_cos, "cos", ty_real_proc, ty_real, bltin_cos)
1105 INIT_SFUNC(init_arctan, "arctan", ty_real_proc, ty_real, bltin_arctan)
1106 INIT_SFUNC(init_ln, "ln", ty_real_proc, ty_real, bltin_ln)
1107 INIT_SFUNC(init_exp, "exp", ty_real_proc, ty_real, bltin_exp)
1108
1109
1110 void
1111 init_bltin ()
1112 {
1113         init_pi ();
1114         init_rand ();
1115         init_vprint ();
1116         init_write ();
1117         init_outreal ();
1118         init_outinteger ();
1119         init_outstring ();
1120         init_outsymbol ();
1121         init_insymbol ();
1122         init_inreal ();
1123         init_print ();
1124         init_length ();
1125         init_entier ();
1126         init_abs ();
1127         init_sign ();
1128         init_sqrt ();
1129         init_sin ();
1130         init_cos ();
1131         init_arctan ();
1132         init_ln ();
1133         init_exp ();
1134 }
1135
1136 /* end of bltin.c */