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