src/int/standard.c

   1      /* Loglan82 Compiler&Interpreter
   2      Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
   3      Copyright (C)  1993, 1994 LITA, Pau
   4
   5      This program is free software; you can redistribute it and/or modify
   6      it under the terms of the GNU General Public License as published by
   7      the Free Software Foundation; either version 2 of the License, or
   8      (at your option) any later version.
   9
  10      This program is distributed in the hope that it will be useful,
  11      but WITHOUT ANY WARRANTY; without even the implied warranty of
  12      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13      GNU General Public License for more details.
  14
  15              You should have received a copy of the GNU General Public License
  16              along with this program; if not, write to the Free Software
  17              Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18
  19  contacts:  Andrzej.Salwicki@univ-pau.fr
  20
  21 or             Andrzej Salwicki
  22                 LITA   Departement d'Informatique
  23                 Universite de Pau
  24                 Avenue de l'Universite
  25                 64000 Pau   FRANCE
  26                  tel.  ++33 59923154    fax. ++33 59841696
  27
  28 =======================================================================
  29 */
  30
  31 #include "depend.h"
  32 #include "genint.h"
  33 #include "int.h"
  34 #include "process.h"
  35 #include "intproto.h"
  36
  37 #include <math.h>
  38 #include <time.h>
  39
  40 /**
  41  * @file
  42  * @brief Call standard procedure
  43  */
  44
  45 /** Process call to a standard proc. */
  46 void standard(word nrproc)
  47 {
  48         word t1, t2, t3, t5, t6;
  49         double r;
  50         bool absent;
  51         int ch, n;
  52         long tim;
  53         char *cp;
  54         FILE *fp;
  55         char s[80];
  56
  57         absent = FALSE;
  58
  59 #ifdef TRACE
  60         fprintf(stderr, "standard procedure %d\n", nrproc);
  61 #endif
  62
  63         switch ((int) nrproc) {
  64         /* new array */
  65         case 1:
  66                 newarry(param[1]. xword, param[0].xword, param[2].xword,
  67                                         &param[3].xvirt, &param[4].xword);
  68                 break;
  69
  70         /* rew */
  71         case 2:
  72         /* avf */
  73         case 3:
  74         /* bsf */
  75         case 4:
  76         /* weo */
  77         case 5:
  78         /* putrec */
  79         case 6:
  80         /* getrec */
  81         case 7:
  82         /* ass */
  83         case 8:
  84         /* assin */
  85         case 9:
  86         /* assout */
  87         case 10:
  88                 absent = TRUE;
  89                 break;
  90
  91         /* unpack:function(s:string):arrayof char */
  92         case 11:
  93                 t1 = strings+param[0].xword+1;
  94                 /* length of the string */
  95                 t6 = M[t1 - 1];
  96                 /* string not null */
  97                 if (t6 > 0) {
  98                         newarry((word) 1, t6, (word)AINT, &param[1].xvirt, &t5);
  99                         t5 += 3;
 100                         cp = (char *) &M[t1];
 101                         while (t6-- > 0) {
 102                                 M[t5++] = *cp++;
 103                         }
 104                 } else {
 105                         /* null string */
 106                         param[1].xvirt.addr = 0;
 107                         param[1].xvirt.mark = 0;
 108                 }
 109                 break;
 110         /* random:function:real */
 111         case 12:
 112                 param[0].xreal = (real)prandom();
 113                 break;
 114         /* time:function:integer */
 115         case 13:
 116                 time(&tim);
 117                 param[0].xword = tim;
 118                 break;
 119         /* sqrt:function(x:real):real */
 120         case 14:
 121                 param[1].xreal = (real)sqrt((double) param[0].xreal);
 122                 break;
 123         /* entier:function(x:real):integer */
 124         case 15:
 125                 param[1].xword = entier((double) param[0].xreal);
 126                 break;
 127         /* round:function(x:real):integer */
 128         case 16:
 129                 param[1].xword = entier((double) (param[0].xreal + 0.5));
 130                 break;
 131         /* unused */
 132         case 17:
 133         /* intrinsic procedure */
 134         case 18:
 135                 absent = TRUE;
 136                 break;
 137         /* imin:function(x, y:integer):integer */
 138         case 19:
 139                 param[2].xword = min(param[0].xword, param[1].xword);
 140                 break;
 141         /* imax:function(x, y:integer):integer */
 142         case 20:
 143                 param[2].xword = max(param[0].xword, param[1].xword);
 144                 break;
 145         /* imin3:function(x, y, z:integer):integer */
 146         case 21:
 147                 t1 = min(param[0].xword, param[1].xword);
 148                 param[3].xword = min(t1, param[2].xword);
 149                 break;
 150         /* imax3:function(x, y, z:integer):integer */
 151         case 22:
 152                 t1 = max(param[0].xword, param[1].xword);
 153                 param[3].xword = max(t1, param[2].xword);
 154                 break;
 155         /* sin:function(x:real):real */
 156         case 23:
 157                 param[1].xreal = (real)sin((double) param[0].xreal);
 158                 break;
 159         /* cos:function(x:real):real */
 160         case 24:
 161                 param[1].xreal = (real)cos((double) param[0].xreal);
 162                 break;
 163         /* tan:function(x:real):real */
 164         case 25:
 165                 r = cos((double) param[0].xreal);
 166                 if (r == 0.0)
 167                         errsignal(RTEDIVBZ);
 168                 param[1].xreal = (real)sin((double) param[0].xreal) / r;
 169                 break;
 170         /* exp:function(x:real):real */
 171         case 26:
 172                 param[1].xreal = (real)exp((double) param[0].xreal);
 173                 break;
 174         /* ln:function(x:real):real */
 175         case 27:
 176                 param[1].xreal = (real)log((double) param[0].xreal);
 177                 break;
 178         /* atan:function(x:real):real */
 179         case 28:
 180                 param[1].xreal = (real)atan((double) param[0].xreal);
 181                 break;
 182         /* endrun:procedure */
 183         case 29:
 184                 endrun(0);
 185                 break;
 186         /* ranset:procedure(x:real) */
 187         case 30:
 188                 ranset();
 189                 break;
 190         /* clock */
 191         case 31:
 192         /* option */
 193         case 32:
 194         /* lock */
 195         case 33:
 196         /* unlock */
 197         case 34:
 198         /* sched, boy! */
 199         case 35:
 200         /* date */
 201         case 36:
 202         /* execpar */
 203         case 37:
 204         /* test&set */
 205         case 38:
 206                 absent = TRUE;
 207                 break;
 208         /* eof */
 209         case 39:
 210                 param[0].xbool = lbool(testeof(stdin));
 211                 break;
 212         /* eof(f) */
 213         case 40:
 214                 loadfile((word) UNKNOWN, &t1, &t2, &fp);
 215                 t3 = M[t2 + FSTAT];
 216                 if (t3 == READING || t3 == UPDATING)
 217                         param[0].xbool = lbool(testeof(fp));
 218                 else
 219                         errsignal(RTEILLIO);
 220                 break;
 221         /* readln */
 222         case 41:
 223                 readln(stdin);
 224                 break;
 225         /* readln(f) */
 226         case 42:
 227                 loadfile((word) READING, &t1, &t2, &fp);
 228                 if (t1 != TEXTF)
 229                         errsignal(RTEILLIO);
 230                 readln(fp);
 231                 break;
 232         /* readchar */
 233         case 43:
 234                 param[0].xword = read_char();
 235                 break;
 236         /* readchar(f) */
 237         case 44:
 238                 loadfile((word) READING, &t1, &t2, &fp);
 239                 if (t1 != TEXTF)
 240                         errsignal(RTEILLIO);
 241                 if ((ch = getc(fp)) == EOF)
 242                         errsignal(RTEIOERR);
 243                 param[0].xword = ch;
 244                 break;
 245         /* readint */
 246         case 45:
 247                 read_str(s);
 248                 param[0].xword = atoi(s);
 249                 break;
 250
 251         case 46: /* readint(f) */
 252                 loadfile((word) READING, &t1, &t2, &fp);
 253                 if (t1 != TEXTF)
 254                         errsignal(RTEILLIO);
 255                 param[0].xword = readint(fp);
 256                 break;
 257         /* readreal */
 258         case 47:
 259                 read_str(s);
 260                 param[0].xreal = (real)atof(s);
 261                 break;
 262         /* readreal(f) */
 263         case 48:
 264                 loadfile((word) READING, &t1, &t2, &fp);
 265                 if (t1 != TEXTF)
 266                         errsignal(RTEILLIO);
 267                 param[0].xreal = (real)readreal(fp);
 268                 break;
 269         /* getchar(f) */
 270         case 49:
 271                 loadfile((word) READING, &t1, &t2, &fp);
 272                 if (t1 != CHARF)
 273                         errsignal(RTEILLIO);
 274                 if ((ch = getc(fp)) == EOF)
 275                         errsignal(RTEIOERR);
 276                 param[0].xword = ch;
 277                 break;
 278         /* getint(f) */
 279         case 50:
 280                 loadfile((word) READING, &t1, &t2, &fp);
 281                 if (t1 != INTF)
 282                         errsignal(RTEILLIO);
 283                 n = fread((char *) &param[ 0 ].xword, sizeof(word), 1, fp);
 284                 if (n != 1)
 285                         errsignal(RTEIOERR);
 286                 break;
 287         /* getreal(f) */
 288         case 51:
 289                 loadfile((word) READING, &t1, &t2, &fp);
 290                 if (t1 != REALF)
 291                         errsignal(RTEILLIO);
 292                 n = fread((char *) &param[0].xreal, sizeof(real), 1, fp);
 293                 if (n != 1)
 294                         errsignal(RTEIOERR);
 295                 break;
 296         /* getobject(f) */
 297         case 52:
 298                 absent = TRUE;
 299                 break;
 300         /* putchar(f) */
 301         case 53:
 302                 loadfile((word) WRITING, &t1, &t2, &fp);
 303                 if (t1 != CHARF)
 304                         errsignal(RTEILLIO);
 305                 ch = (char) param[ 0 ].xword;
 306                 if (putc(ch, fp) == EOF)
 307                         errsignal(RTEIOERR);
 308                 break;
 309         /* putint(f) */
 310         case 54:
 311                 loadfile((word) WRITING, &t1, &t2, &fp);
 312                 if (t1 != INTF)
 313                         errsignal(RTEILLIO);
 314                 n = fwrite((char *) &param[ 0 ].xword, sizeof(word), 1, fp);
 315                 if (n != 1)
 316                         errsignal(RTEIOERR);
 317                 break;
 318         /* putreal(f) */
 319         case 55:
 320                 loadfile((word) WRITING, &t1, &t2, &fp);
 321                 if (t1 != REALF)
 322                         errsignal(RTEILLIO);
 323                 n = fwrite((char *) &param[ 0 ].xreal, sizeof(real), 1, fp);
 324                 if (n != 1)
 325                         errsignal(RTEIOERR);
 326                 break;
 327         /* putobject(f) */
 328         case 56:
 329         /* putstring(f) */
 330         case 57:
 331                 absent = TRUE;
 332                 break;
 333         /* writeln(f) */
 334         case 58:
 335                 loadfile((word) WRITING, &t1, &t2, &fp);
 336                 if (t1 != TEXTF)
 337                         errsignal(RTEILLIO);
 338                 if (putc('\n', fp) == EOF)
 339                         errsignal(RTEIOERR);
 340                 if (fflush(fp))
 341                         errsignal(RTEIOERR);
 342                 break;
 343         /* writeln */
 344         case 59:
 345                 write_str("\n");
 346                 break;
 347         /* writechar(f) */
 348         case 60:
 349                 loadfile((word) WRITING, &t1, &t2, &fp);
 350                 if (t1 != TEXTF)
 351                         errsignal(RTEILLIO);
 352                 if (putc((char) param[0].xword, fp) == EOF)
 353                         errsignal(RTEIOERR);
 354                 break;
 355         /* writechar */
 356         case 61:
 357                 write_char((char) param[0].xword);
 358                 break;
 359         /* writeint(f) */
 360         case 62:
 361                 loadfile((word) WRITING, &t1, &t2, &fp);
 362                 if (t1 != TEXTF)
 363                         errsignal(RTEILLIO);
 364                 writeint(param[0].xword, param[1].xword, fp);
 365                 break;
 366         /* writeint */
 367         case 63:
 368                 writeint(param[0].xword, param[1].xword, stdout);
 369                 break;
 370         /* writereal0(f) */
 371         case 64:
 372         /* writereal1(f) */
 373         case 66:
 374         /* writereal2(f) */
 375         case 68:
 376                 loadfile((word) WRITING, &t1, &t2, &fp);
 377                 if (t1 != TEXTF)
 378                         errsignal(RTEILLIO);
 379                 writereal((double) param[0].xreal, param[1].xword,
 380                                                         param[2].xword, fp);
 381                 break;
 382         /* writereal0 */
 383         case 65:
 384         /* writereal1 */
 385         case 67:
 386         /* writereal2 */
 387         case 69:
 388                 writereal((double) param[0].xreal, param[1].xword,
 389                                                         param[2].xword, stdout);
 390                 break;
 391         /* writestring(f) */
 392         case 70:
 393                 loadfile((word) WRITING, &t1, &t2, &fp);
 394                 if (t1 != TEXTF)
 395                         errsignal(RTEILLIO);
 396                 writestring(param[0].xword, param[1].xword, fp);
 397                 break;
 398         /* writestring */
 399         case 71:
 400                 writestring(param[0].xword, param[1].xword, stdout);
 401                 break;
 402         /* open temporary file */
 403         case 72:
 404                 genfileobj(TRUE, param[1].xword, tempfilename(),
 405                                                         &param[0].xvirt, &t1);
 406                 break;
 407         /* open external file */
 408         case 73:
 409                 genfileobj(FALSE, param[1].xword, asciiz(&param[2].xvirt),
 410                                                         &param[0].xvirt, &t1);
 411                 break;
 412         /* eoln */
 413         case 74:
 414                 param[0].xbool = lbool(testeoln(stdin));
 415                 break;
 416         /* eoln(f) */
 417         case 75:
 418                 loadfile((word) READING, &t1, &t2, &fp);
 419                 if (t1 != TEXTF) errsignal(RTEILLIO);
 420                 param[0].xbool = lbool(testeoln(fp));
 421                 break;
 422         /* this coroutine */
 423         case 76:
 424                 loadvirt(param[0].xvirt,
 425                         thisp->prochead + M[thisp->prochead] + CHD);
 426                 break;
 427         /* this process */
 428         case 77:
 429                 {
 430                         procaddr p;
 431                         virtaddr v;
 432                         p.node = ournode;
 433                         p.pix  = thispix;
 434                         p.mark = thisp->mark;
 435                         mess2obj(thisp, &p, &v);
 436                         param[0].xvirt = v;
 437                 }
 438                 break;
 439         /* reset:procedure(f:file) */
 440         case 78:
 441                 if (member(&param[0].xvirt, &t2))
 442                         reset(t2);
 443                 else
 444                         errsignal(RTEREFTN);
 445                 break;
 446         /* rewrite:procedure(f:file) */
 447         case 79:
 448                 if (member(&param[0].xvirt, &t2))
 449                         rewrite(t2);
 450                 else
 451                         errsignal(RTEREFTN);
 452                 break;
 453         /* unlink:procedure(f:file) */
 454         case 80:
 455                 delete(&param[0].xvirt);
 456                 break;
 457         /* seek:procedure(f:file, offset, base:integer) */
 458         case 81:
 459                 storevirt(param[0].xvirt, currfile);
 460                 loadfile((word) UPDATING, &t1, &t2, &fp);
 461                 if (t1 != DIRECT)
 462                         errsignal(RTEILLIO);
 463                 if (fseek(fp, (long) param[1].xword, (int) param[2].xword))
 464                         errsignal(RTEIOERR);
 465                 break;
 466         /* getrec(f, a, n) */
 467         case 82:
 468                 loadfile((word) UPDATING, &t1, &t2, &fp);
 469                 if (t1 != DIRECT)
 470                         errsignal(RTEILLIO);
 471                 param[1].xword = directio(&param[0].xvirt, param[1].xword,
 472                                                         (int (*)())fread, fp);
 473                 break;
 474         /* putrec(f, a, n) */
 475         case 83:
 476                 loadfile((word) UPDATING, &t1, &t2, &fp);
 477                 if (t1 != DIRECT) errsignal(RTEILLIO);
 478                 param[1].xword = directio(&param[0].xvirt, param[1].xword,
 479                                                         (int (*)())fwrite, fp);
 480                 break;
 481         /* position:function(f:file):real */
 482         case 84:
 483                 storevirt(param[0].xvirt, currfile);
 484                 loadfile((word) UPDATING, &t1, &t2, &fp);
 485                 if (t1 != DIRECT)
 486                         errsignal(RTEILLIO);
 487                 param[1].xword =(int) ftell(fp);
 488                 break;
 489         /* memavail:function:integer */
 490         case 98:
 491                 param[0].xword = memavail();
 492                 break;
 493         /* exec:function(c:arrayof char):integer */
 494         case 99:
 495                 cp = asciiz(&param[0].xvirt);
 496                 param[1].xword = system(cp);
 497                 free(cp);
 498                 break;
 499
 500         default:
 501                 nonstandard(nrproc);
 502                 break;
 503         }
 504 #if TRACE
 505         fflush(stdout);
 506 #endif
 507         if (absent)
 508                 errsignal(RTEUNSTP);
 509 }
 510