sources/int/standard.c

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