X-Git-Url: https://git.dlugolecki.net.pl/?a=blobdiff_plain;f=int%2Fstandard.c;h=e865220236019e84a605e5126958f2012324f5d2;hb=HEAD;hp=74a67d70ada82476f1e90dc4e5de8448707b483a;hpb=9db87b545def5d31a64608f2eb082d915ad5efa4;p=vlp.git diff --git a/int/standard.c b/int/standard.c deleted file mode 100644 index 74a67d7..0000000 --- a/int/standard.c +++ /dev/null @@ -1,459 +0,0 @@ - /* 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 -#include - -/* 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); -} - -