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
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
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
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
19 contacts: Andrzej.Salwicki@univ-pau.fr
\r
22 LITA Departement d'Informatique
\r
24 Avenue de l'Universite
\r
26 tel. ++33 59923154 fax. ++33 59841696
\r
28 =======================================================================
\r
34 #include "process.h"
\r
35 #include "intproto.h"
\r
40 /* Call standard procedure */
\r
42 void standard(nrproc) /* Process call to a standard proc. */
\r
45 word t1, t2, t3, t5, t6;
\r
56 fprintf( stderr, "standard procedure %d\n", nrproc );
\r
59 switch ((int) nrproc)
\r
61 case 1 : /* new array */
\r
62 newarry(param[ 1 ].xword, param[ 0 ].xword, param[ 2 ].xword,
\r
63 ¶m[ 3 ].xvirt, ¶m[ 4 ].xword);
\r
70 case 6 : /* putrec */
\r
71 case 7 : /* getrec */
\r
73 case 9 : /* assin */
\r
74 case 10 : /* assout */
\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
83 newarry((word) 1, t6, (word) AINT, ¶m[ 1 ].xvirt, &t5);
\r
85 cp = (char *) &M[ t1 ];
\r
86 while (t6-- > 0) M[ t5++ ] = *cp++;
\r
88 else /* null string */
\r
90 param[ 1 ].xvirt.addr = 0;
\r
91 param[ 1 ].xvirt.mark = 0;
\r
95 case 12 : /* random:function:real */
\r
96 param[ 0 ].xreal = (real)prandom();
\r
99 case 13 : /* time:function:integer */
\r
101 param[ 0 ].xword = tim;
\r
104 case 14 : /* sqrt:function(x:real):real */
\r
105 param[ 1 ].xreal = (real)sqrt((double) param[ 0 ].xreal);
\r
108 case 15 : /* entier:function(x:real):integer */
\r
109 param[ 1 ].xword = entier((double) param[ 0 ].xreal);
\r
112 case 16 : /* round:function(x:real):integer */
\r
113 param[ 1 ].xword = entier((double) (param[ 0 ].xreal+0.5));
\r
116 case 17 : /* unused */
\r
117 case 18 : /* intrinsic procedure */
\r
121 case 19 : /* imin:function(x, y:integer):integer */
\r
122 param[ 2 ].xword = min(param[ 0 ].xword, param[ 1 ].xword);
\r
125 case 20 : /* imax:function(x, y:integer):integer */
\r
126 param[ 2 ].xword = max(param[ 0 ].xword, param[ 1 ].xword);
\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
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
139 case 23 : /* sin:function(x:real):real */
\r
140 param[ 1 ].xreal = (real)sin((double) param[ 0 ].xreal);
\r
143 case 24 : /* cos:function(x:real):real */
\r
144 param[ 1 ].xreal = (real)cos((double) param[ 0 ].xreal);
\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
153 case 26 : /* exp:function(x:real):real */
\r
154 param[ 1 ].xreal = (real)exp((double) param[ 0 ].xreal);
\r
157 case 27 : /* ln:function(x:real):real */
\r
158 param[ 1 ].xreal = (real)log((double) param[ 0 ].xreal);
\r
161 case 28 : /* atan:function(x:real):real */
\r
162 param[ 1 ].xreal = (real)atan((double) param[ 0 ].xreal);
\r
165 case 29 : /* endrun:procedure */
\r
169 case 30 : /* ranset:procedure(x:real) */
\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
184 case 39 : /* eof */
\r
185 param[ 0 ].xbool = lbool(testeof(stdin));
\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
196 case 41 : /* readln */
\r
200 case 42 : /* readln(f) */
\r
201 loadfile((word) READING, &t1, &t2, &fp);
\r
202 if (t1 != TEXTF) errsignal(RTEILLIO);
\r
206 case 43 : /* readchar */
\r
207 param[ 0 ].xword = getc(stdin);
\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
217 case 45 : /* readint */
\r
218 param[ 0 ].xword = readint(stdin);
\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
227 case 47 : /* readreal */
\r
228 param[ 0 ].xreal = (real)readreal(stdin);
\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
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
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 *) ¶m[ 0 ].xword, sizeof(word), 1, fp);
\r
248 if (n != 1) errsignal(RTEIOERR);
\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 *) ¶m[ 0 ].xreal, sizeof(real), 1, fp);
\r
255 if (n != 1) errsignal(RTEIOERR);
\r
258 case 52 : /* getobject(f) */
\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
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 *) ¶m[ 0 ].xword, sizeof(word), 1, fp);
\r
273 if (n != 1) errsignal(RTEIOERR);
\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 *) ¶m[ 0 ].xreal, sizeof(real), 1, fp);
\r
280 if (n != 1) errsignal(RTEIOERR);
\r
283 case 56 : /* putobject(f) */
\r
284 case 57 : /* putstring(f) */
\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
295 case 59 : /* writeln */
\r
296 putc('\n', stdout);
\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
306 case 61 : /* writechar */
\r
307 putc((char) param[ 0 ].xword, stdout);
\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
316 case 63 : /* writeint */
\r
317 writeint(param[ 0 ].xword, param[ 1 ].xword, stdout);
\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
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
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
342 case 71 : /* writestring */
\r
343 writestring(param[ 0 ].xword, param[ 1 ].xword, stdout);
\r
346 case 72 : /* open temporary file */
\r
347 genfileobj(TRUE , param[ 1 ].xword, tempfilename(),
\r
348 ¶m[ 0 ].xvirt, &t1);
\r
351 case 73 : /* open external file */
\r
352 genfileobj(FALSE, param[ 1 ].xword, asciiz(¶m[ 2 ].xvirt),
\r
353 ¶m[ 0 ].xvirt, &t1);
\r
356 case 74 : /* eoln */
\r
357 param[ 0 ].xbool = lbool(testeoln(stdin));
\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
366 case 76 : /* this coroutine */
\r
367 loadvirt(param[ 0 ].xvirt,
\r
368 thisp->prochead+M[ thisp->prochead ]+CHD);
\r
371 case 77 : /* this process */
\r
377 p.mark = thisp->mark;
\r
378 mess2obj( thisp, &p, &v );
\r
379 param[ 0 ].xvirt = v;
\r
383 case 78 : /* reset:procedure(f:file) */
\r
384 if (member(¶m[ 0 ].xvirt, &t2))
\r
386 else errsignal(RTEREFTN);
\r
389 case 79 : /* rewrite:procedure(f:file) */
\r
390 if (member(¶m[ 0 ].xvirt, &t2))
\r
392 else errsignal(RTEREFTN);
\r
395 case 80 : /* unlink:procedure(f:file) */
\r
396 delete(¶m[ 0 ].xvirt);
\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
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
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
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
436 case 98 : /* memavail:function:integer */
\r
437 param[ 0 ].xword = memavail();
\r
440 case 99 : /* exec:function(c:arrayof char):integer */
\r
441 cp = asciiz(¶m[ 0 ].xvirt);
\r
442 param[ 1 ].xword = system(cp);
\r
447 nonstandard(nrproc);
\r
453 if (absent) errsignal(RTEUNSTP);
\r