+++ /dev/null
- /* Loglan82 Compiler&Interpreter
- Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
- Copyright (C) 1993, 1994 LITA, Pau
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- contacts: Andrzej.Salwicki@univ-pau.fr
-
-or Andrzej Salwicki
- LITA Departement d'Informatique
- Universite de Pau
- Avenue de l'Universite
- 64000 Pau FRANCE
- tel. ++33 59923154 fax. ++33 59841696
-
-=======================================================================
-*/
-
-#include "depend.h"
-#include "genint.h"
-#include "int.h"
-#include "process.h"
-#include "intproto.h"
-
-#include <math.h>
-#include <time.h>
-
-/* Call standard procedure */
-
-void standard(nrproc) /* Process call to a standard proc. */
-word nrproc;
-{
- word t1, t2, t3, t5, t6;
- double r;
- bool absent;
- int ch, n;
- long tim;
- char *cp;
- FILE *fp;
- char s[80];
-
- absent = FALSE;
-
-#ifdef TRACE
- fprintf( stderr, "standard procedure %d\n", nrproc );
-#endif
-
- switch ((int) nrproc)
- {
- case 1 : /* new array */
- newarry(param[ 1 ].xword, param[ 0 ].xword, param[ 2 ].xword,
- ¶m[ 3 ].xvirt, ¶m[ 4 ].xword);
- break;
-
- case 2 : /* rew */
- case 3 : /* avf */
- case 4 : /* bsf */
- case 5 : /* weo */
- case 6 : /* putrec */
- case 7 : /* getrec */
- case 8 : /* ass */
- case 9 : /* assin */
- case 10 : /* assout */
- absent = TRUE;
- break;
-
- case 11 : /* unpack:function(s:string):arrayof char */
- t1 = strings+param[ 0 ].xword+1;
- t6 = M[ t1-1 ]; /* length of the string */
- if (t6 > 0) /* string not null */
- {
- newarry((word) 1, t6, (word) AINT, ¶m[ 1 ].xvirt, &t5);
- t5 += 3;
- cp = (char *) &M[ t1 ];
- while (t6-- > 0) M[ t5++ ] = *cp++;
- }
- else /* null string */
- {
- param[ 1 ].xvirt.addr = 0;
- param[ 1 ].xvirt.mark = 0;
- }
- break;
-
- case 12 : /* random:function:real */
- param[ 0 ].xreal = (real)prandom();
- break;
-
- case 13 : /* time:function:integer */
- time(&tim);
- param[ 0 ].xword = tim;
- break;
-
- case 14 : /* sqrt:function(x:real):real */
- param[ 1 ].xreal = (real)sqrt((double) param[ 0 ].xreal);
- break;
-
- case 15 : /* entier:function(x:real):integer */
- param[ 1 ].xword = entier((double) param[ 0 ].xreal);
- break;
-
- case 16 : /* round:function(x:real):integer */
- param[ 1 ].xword = entier((double) (param[ 0 ].xreal+0.5));
- break;
-
- case 17 : /* unused */
- case 18 : /* intrinsic procedure */
- absent = TRUE;
- break;
-
- case 19 : /* imin:function(x, y:integer):integer */
- param[ 2 ].xword = min(param[ 0 ].xword, param[ 1 ].xword);
- break;
-
- case 20 : /* imax:function(x, y:integer):integer */
- param[ 2 ].xword = max(param[ 0 ].xword, param[ 1 ].xword);
- break;
-
- case 21 : /* imin3:function(x, y, z:integer):integer */
- t1 = min(param[ 0 ].xword, param[ 1 ].xword);
- param[ 3 ].xword = min(t1, param[ 2 ].xword);
- break;
-
- case 22 : /* imax3:function(x, y, z:integer):integer */
- t1 = max(param[ 0 ].xword, param[ 1 ].xword);
- param[ 3 ].xword = max(t1, param[ 2 ].xword);
- break;
-
- case 23 : /* sin:function(x:real):real */
- param[ 1 ].xreal = (real)sin((double) param[ 0 ].xreal);
- break;
-
- case 24 : /* cos:function(x:real):real */
- param[ 1 ].xreal = (real)cos((double) param[ 0 ].xreal);
- break;
-
- case 25 : /* tan:function(x:real):real */
- r = cos((double) param[ 0 ].xreal);
- if (r == 0.0) errsignal(RTEDIVBZ);
- param[ 1 ].xreal = (real)sin((double) param[ 0 ].xreal) / r;
- break;
-
- case 26 : /* exp:function(x:real):real */
- param[ 1 ].xreal = (real)exp((double) param[ 0 ].xreal);
- break;
-
- case 27 : /* ln:function(x:real):real */
- param[ 1 ].xreal = (real)log((double) param[ 0 ].xreal);
- break;
-
- case 28 : /* atan:function(x:real):real */
- param[ 1 ].xreal = (real)atan((double) param[ 0 ].xreal);
- break;
-
- case 29 : /* endrun:procedure */
- endrun(0);
- break;
-
- case 30 : /* ranset:procedure(x:real) */
- ranset();
- break;
-
- case 31 : /* clock */
- case 32 : /* option */
- case 33 : /* lock */
- case 34 : /* unlock */
- case 35 : /* sched, boy! */
- case 36 : /* date */
- case 37 : /* execpar */
- case 38 : /* test&set */
- absent = TRUE;
- break;
-
- case 39 : /* eof */
- param[ 0 ].xbool = lbool(testeof(stdin));
- break;
-
- case 40 : /* eof(f) */
- loadfile((word) UNKNOWN, &t1, &t2, &fp);
- t3 = M[ t2+FSTAT ];
- if (t3 == READING || t3 == UPDATING)
- param[ 0 ].xbool = lbool(testeof(fp));
- else errsignal(RTEILLIO);
- break;
-
- case 41 : /* readln */
- readln(stdin);
- break;
-
- case 42 : /* readln(f) */
- loadfile((word) READING, &t1, &t2, &fp);
- if (t1 != TEXTF) errsignal(RTEILLIO);
- readln(fp);
- break;
-
- case 43 : /* readchar */
- param[ 0 ].xword = read_char();
- break;
-
- case 44 : /* readchar(f) */
- loadfile((word) READING, &t1, &t2, &fp);
- if (t1 != TEXTF) errsignal(RTEILLIO);
- if ((ch = getc(fp)) == EOF) errsignal(RTEIOERR);
- param[ 0 ].xword = ch;
- break;
-
- case 45 : /* readint */
- read_str(s);
- param[ 0 ].xword = atoi(s);
- break;
-
- case 46 : /* readint(f) */
- loadfile((word) READING, &t1, &t2, &fp);
- if (t1 != TEXTF) errsignal(RTEILLIO);
- param[ 0 ].xword = readint(fp);
- break;
-
- case 47 : /* readreal */
- read_str(s);
- param[ 0 ].xreal = (real)atof(s);
- break;
-
- case 48 : /* readreal(f) */
- loadfile((word) READING, &t1, &t2, &fp);
- if (t1 != TEXTF) errsignal(RTEILLIO);
- param[ 0 ].xreal = (real)readreal(fp);
- break;
-
- case 49 : /* getchar(f) */
- loadfile((word) READING, &t1, &t2, &fp);
- if (t1 != CHARF) errsignal(RTEILLIO);
- if ((ch = getc(fp)) == EOF) errsignal(RTEIOERR);
- param[ 0 ].xword = ch;
- break;
-
- case 50 : /* getint(f) */
- loadfile((word) READING, &t1, &t2, &fp);
- if (t1 != INTF) errsignal(RTEILLIO);
- n = fread((char *) ¶m[ 0 ].xword, sizeof(word), 1, fp);
- if (n != 1) errsignal(RTEIOERR);
- break;
-
- case 51 : /* getreal(f) */
- loadfile((word) READING, &t1, &t2, &fp);
- if (t1 != REALF) errsignal(RTEILLIO);
- n = fread((char *) ¶m[ 0 ].xreal, sizeof(real), 1, fp);
- if (n != 1) errsignal(RTEIOERR);
- break;
-
- case 52 : /* getobject(f) */
- absent = TRUE;
- break;
-
- case 53 : /* putchar(f) */
- loadfile((word) WRITING, &t1, &t2, &fp);
- if (t1 != CHARF) errsignal(RTEILLIO);
- ch = (char) param[ 0 ].xword;
- if (putc(ch, fp) == EOF) errsignal(RTEIOERR);
- break;
-
- case 54 : /* putint(f) */
- loadfile((word) WRITING, &t1, &t2, &fp);
- if (t1 != INTF) errsignal(RTEILLIO);
- n = fwrite((char *) ¶m[ 0 ].xword, sizeof(word), 1, fp);
- if (n != 1) errsignal(RTEIOERR);
- break;
-
- case 55 : /* putreal(f) */
- loadfile((word) WRITING, &t1, &t2, &fp);
- if (t1 != REALF) errsignal(RTEILLIO);
- n = fwrite((char *) ¶m[ 0 ].xreal, sizeof(real), 1, fp);
- if (n != 1) errsignal(RTEIOERR);
- break;
-
- case 56 : /* putobject(f) */
- case 57 : /* putstring(f) */
- absent = TRUE;
- break;
-
- case 58 : /* writeln(f) */
- loadfile((word) WRITING, &t1, &t2, &fp);
- if (t1 != TEXTF) errsignal(RTEILLIO);
- if (putc('\n', fp) == EOF) errsignal(RTEIOERR);
- if (fflush(fp)) errsignal(RTEIOERR);
- break;
-
- case 59 : /* writeln */
- write_str("\n");
- break;
-
- case 60 : /* writechar(f) */
- loadfile((word) WRITING, &t1, &t2, &fp);
- if (t1 != TEXTF) errsignal(RTEILLIO);
- if (putc((char) param[ 0 ].xword, fp) == EOF)
- errsignal(RTEIOERR);
- break;
-
- case 61 : /* writechar */
- write_char((char) param[ 0 ].xword);
- break;
-
- case 62 : /* writeint(f) */
- loadfile((word) WRITING, &t1, &t2, &fp);
- if (t1 != TEXTF) errsignal(RTEILLIO);
- writeint(param[ 0 ].xword, param[ 1 ].xword, fp);
- break;
-
- case 63 : /* writeint */
- writeint(param[ 0 ].xword, param[ 1 ].xword, stdout);
- break;
-
- case 64 : /* writereal0(f) */
- case 66 : /* writereal1(f) */
- case 68 : /* writereal2(f) */
- loadfile((word) WRITING, &t1, &t2, &fp);
- if (t1 != TEXTF) errsignal(RTEILLIO);
- writereal((double) param[ 0 ].xreal, param[ 1 ].xword,
- param[ 2 ].xword, fp);
- break;
-
- case 65 : /* writereal0 */
- case 67 : /* writereal1 */
- case 69 : /* writereal2 */
- writereal((double) param[ 0 ].xreal, param[ 1 ].xword,
- param[ 2 ].xword, stdout);
- break;
-
- case 70 : /* writestring(f) */
- loadfile((word) WRITING, &t1, &t2, &fp);
- if (t1 != TEXTF) errsignal(RTEILLIO);
- writestring(param[ 0 ].xword, param[ 1 ].xword, fp);
- break;
-
- case 71 : /* writestring */
- writestring(param[ 0 ].xword, param[ 1 ].xword, stdout);
- break;
-
- case 72 : /* open temporary file */
- genfileobj(TRUE , param[ 1 ].xword, tempfilename(),
- ¶m[ 0 ].xvirt, &t1);
- break;
-
- case 73 : /* open external file */
- genfileobj(FALSE, param[ 1 ].xword, asciiz(¶m[ 2 ].xvirt),
- ¶m[ 0 ].xvirt, &t1);
- break;
-
- case 74 : /* eoln */
- param[ 0 ].xbool = lbool(testeoln(stdin));
- break;
-
- case 75 : /* eoln(f) */
- loadfile((word) READING, &t1, &t2, &fp);
- if (t1 != TEXTF) errsignal(RTEILLIO);
- param[ 0 ].xbool = lbool(testeoln(fp));
- break;
-
- case 76 : /* this coroutine */
- loadvirt(param[ 0 ].xvirt,
- thisp->prochead+M[ thisp->prochead ]+CHD);
- break;
-
- case 77 : /* this process */
- {
- procaddr p;
- virtaddr v;
- p.node = ournode;
- p.pix = thispix;
- p.mark = thisp->mark;
- mess2obj( thisp, &p, &v );
- param[ 0 ].xvirt = v;
- }
- break;
-
- case 78 : /* reset:procedure(f:file) */
- if (member(¶m[ 0 ].xvirt, &t2))
- reset(t2);
- else errsignal(RTEREFTN);
- break;
-
- case 79 : /* rewrite:procedure(f:file) */
- if (member(¶m[ 0 ].xvirt, &t2))
- rewrite(t2);
- else errsignal(RTEREFTN);
- break;
-
- case 80 : /* unlink:procedure(f:file) */
- delete(¶m[ 0 ].xvirt);
- break;
-
- case 81 : /* seek:procedure(f:file, offset, base:integer) */
- storevirt(param[ 0 ].xvirt, currfile);
- loadfile((word) UPDATING, &t1, &t2, &fp);
- if (t1 != DIRECT) errsignal(RTEILLIO);
- if (fseek(fp, (long) param[ 1 ].xword, (int) param[ 2 ].xword))
- errsignal(RTEIOERR);
- break;
-
- case 82 : /* getrec(f, a, n) */
- loadfile((word) UPDATING, &t1, &t2, &fp);
- if (t1 != DIRECT) errsignal(RTEILLIO);
- param[ 1 ].xword = directio(
- ¶m[ 0 ].xvirt,
- param[ 1 ].xword,
- (int (*)())fread,
- fp
- );
- break;
-
- case 83 : /* putrec(f, a, n) */
- loadfile((word) UPDATING, &t1, &t2, &fp);
- if (t1 != DIRECT) errsignal(RTEILLIO);
- param[ 1 ].xword = directio(
- ¶m[ 0 ].xvirt,
- param[ 1 ].xword,
- (int (*)())fwrite,
- fp
- );
- break;
-
- case 84 : /* position:function(f:file):real */
- storevirt(param[ 0 ].xvirt, currfile);
- loadfile((word) UPDATING, &t1, &t2, &fp);
- if (t1 != DIRECT) errsignal(RTEILLIO);
- param[ 1 ].xword =(int) ftell(fp);
- break;
-
- case 98 : /* memavail:function:integer */
- param[ 0 ].xword = memavail();
- break;
-
- case 99 : /* exec:function(c:arrayof char):integer */
- cp = asciiz(¶m[ 0 ].xvirt);
- param[ 1 ].xword = system(cp);
- free(cp);
- break;
-
- default :
- nonstandard(nrproc);
- break;
- }
-# if TRACE
- fflush( stdout );
-# endif
- if (absent) errsignal(RTEUNSTP);
-}
-
-
projects / vlp.git / blobdiff