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