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