1 /* Loglan82 Compiler&Interpreter
2 Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
3 Copyright (C) 1993, 1994 LITA, Pau
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.
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.
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.
19 contacts: Andrzej.Salwicki@univ-pau.fr
22 LITA Departement d'Informatique
24 Avenue de l'Universite
26 tel. ++33 59923154 fax. ++33 59841696
28 =======================================================================
40 /* Call standard procedure */
42 void standard(nrproc) /* Process call to a standard proc. */
45 word t1, t2, t3, t5, t6;
56 fprintf( stderr, "standard procedure %d\n", nrproc );
61 case 1 : /* new array */
62 newarry(param[ 1 ].xword, param[ 0 ].xword, param[ 2 ].xword,
63 ¶m[ 3 ].xvirt, ¶m[ 4 ].xword);
74 case 10 : /* assout */
78 case 11 : /* unpack:function(s:string):arrayof char */
79 t1 = strings+param[ 0 ].xword+1;
80 t6 = M[ t1-1 ]; /* length of the string */
81 if (t6 > 0) /* string not null */
83 newarry((word) 1, t6, (word) AINT, ¶m[ 1 ].xvirt, &t5);
85 cp = (char *) &M[ t1 ];
86 while (t6-- > 0) M[ t5++ ] = *cp++;
88 else /* null string */
90 param[ 1 ].xvirt.addr = 0;
91 param[ 1 ].xvirt.mark = 0;
95 case 12 : /* random:function:real */
96 param[ 0 ].xreal = (real)prandom();
99 case 13 : /* time:function:integer */
101 param[ 0 ].xword = tim;
104 case 14 : /* sqrt:function(x:real):real */
105 param[ 1 ].xreal = (real)sqrt((double) param[ 0 ].xreal);
108 case 15 : /* entier:function(x:real):integer */
109 param[ 1 ].xword = entier((double) param[ 0 ].xreal);
112 case 16 : /* round:function(x:real):integer */
113 param[ 1 ].xword = entier((double) (param[ 0 ].xreal+0.5));
116 case 17 : /* unused */
117 case 18 : /* intrinsic procedure */
121 case 19 : /* imin:function(x, y:integer):integer */
122 param[ 2 ].xword = min(param[ 0 ].xword, param[ 1 ].xword);
125 case 20 : /* imax:function(x, y:integer):integer */
126 param[ 2 ].xword = max(param[ 0 ].xword, param[ 1 ].xword);
129 case 21 : /* imin3:function(x, y, z:integer):integer */
130 t1 = min(param[ 0 ].xword, param[ 1 ].xword);
131 param[ 3 ].xword = min(t1, param[ 2 ].xword);
134 case 22 : /* imax3:function(x, y, z:integer):integer */
135 t1 = max(param[ 0 ].xword, param[ 1 ].xword);
136 param[ 3 ].xword = max(t1, param[ 2 ].xword);
139 case 23 : /* sin:function(x:real):real */
140 param[ 1 ].xreal = (real)sin((double) param[ 0 ].xreal);
143 case 24 : /* cos:function(x:real):real */
144 param[ 1 ].xreal = (real)cos((double) param[ 0 ].xreal);
147 case 25 : /* tan:function(x:real):real */
148 r = cos((double) param[ 0 ].xreal);
149 if (r == 0.0) errsignal(RTEDIVBZ);
150 param[ 1 ].xreal = (real)sin((double) param[ 0 ].xreal) / r;
153 case 26 : /* exp:function(x:real):real */
154 param[ 1 ].xreal = (real)exp((double) param[ 0 ].xreal);
157 case 27 : /* ln:function(x:real):real */
158 param[ 1 ].xreal = (real)log((double) param[ 0 ].xreal);
161 case 28 : /* atan:function(x:real):real */
162 param[ 1 ].xreal = (real)atan((double) param[ 0 ].xreal);
165 case 29 : /* endrun:procedure */
169 case 30 : /* ranset:procedure(x:real) */
173 case 31 : /* clock */
174 case 32 : /* option */
176 case 34 : /* unlock */
177 case 35 : /* sched, boy! */
179 case 37 : /* execpar */
180 case 38 : /* test&set */
185 param[ 0 ].xbool = lbool(testeof(stdin));
188 case 40 : /* eof(f) */
189 loadfile((word) UNKNOWN, &t1, &t2, &fp);
191 if (t3 == READING || t3 == UPDATING)
192 param[ 0 ].xbool = lbool(testeof(fp));
193 else errsignal(RTEILLIO);
196 case 41 : /* readln */
200 case 42 : /* readln(f) */
201 loadfile((word) READING, &t1, &t2, &fp);
202 if (t1 != TEXTF) errsignal(RTEILLIO);
206 case 43 : /* readchar */
207 param[ 0 ].xword = getc(stdin);
210 case 44 : /* readchar(f) */
211 loadfile((word) READING, &t1, &t2, &fp);
212 if (t1 != TEXTF) errsignal(RTEILLIO);
213 if ((ch = getc(fp)) == EOF) errsignal(RTEIOERR);
214 param[ 0 ].xword = ch;
217 case 45 : /* readint */
218 param[ 0 ].xword = readint(stdin);
221 case 46 : /* readint(f) */
222 loadfile((word) READING, &t1, &t2, &fp);
223 if (t1 != TEXTF) errsignal(RTEILLIO);
224 param[ 0 ].xword = readint(fp);
227 case 47 : /* readreal */
228 param[ 0 ].xreal = (real)readreal(stdin);
231 case 48 : /* readreal(f) */
232 loadfile((word) READING, &t1, &t2, &fp);
233 if (t1 != TEXTF) errsignal(RTEILLIO);
234 param[ 0 ].xreal = (real)readreal(fp);
237 case 49 : /* getchar(f) */
238 loadfile((word) READING, &t1, &t2, &fp);
239 if (t1 != CHARF) errsignal(RTEILLIO);
240 if ((ch = getc(fp)) == EOF) errsignal(RTEIOERR);
241 param[ 0 ].xword = ch;
244 case 50 : /* getint(f) */
245 loadfile((word) READING, &t1, &t2, &fp);
246 if (t1 != INTF) errsignal(RTEILLIO);
247 n = fread((char *) ¶m[ 0 ].xword, sizeof(word), 1, fp);
248 if (n != 1) errsignal(RTEIOERR);
251 case 51 : /* getreal(f) */
252 loadfile((word) READING, &t1, &t2, &fp);
253 if (t1 != REALF) errsignal(RTEILLIO);
254 n = fread((char *) ¶m[ 0 ].xreal, sizeof(real), 1, fp);
255 if (n != 1) errsignal(RTEIOERR);
258 case 52 : /* getobject(f) */
262 case 53 : /* putchar(f) */
263 loadfile((word) WRITING, &t1, &t2, &fp);
264 if (t1 != CHARF) errsignal(RTEILLIO);
265 ch = (char) param[ 0 ].xword;
266 if (putc(ch, fp) == EOF) errsignal(RTEIOERR);
269 case 54 : /* putint(f) */
270 loadfile((word) WRITING, &t1, &t2, &fp);
271 if (t1 != INTF) errsignal(RTEILLIO);
272 n = fwrite((char *) ¶m[ 0 ].xword, sizeof(word), 1, fp);
273 if (n != 1) errsignal(RTEIOERR);
276 case 55 : /* putreal(f) */
277 loadfile((word) WRITING, &t1, &t2, &fp);
278 if (t1 != REALF) errsignal(RTEILLIO);
279 n = fwrite((char *) ¶m[ 0 ].xreal, sizeof(real), 1, fp);
280 if (n != 1) errsignal(RTEIOERR);
283 case 56 : /* putobject(f) */
284 case 57 : /* putstring(f) */
288 case 58 : /* writeln(f) */
289 loadfile((word) WRITING, &t1, &t2, &fp);
290 if (t1 != TEXTF) errsignal(RTEILLIO);
291 if (putc('\n', fp) == EOF) errsignal(RTEIOERR);
292 if (fflush(fp)) errsignal(RTEIOERR);
295 case 59 : /* writeln */
299 case 60 : /* writechar(f) */
300 loadfile((word) WRITING, &t1, &t2, &fp);
301 if (t1 != TEXTF) errsignal(RTEILLIO);
302 if (putc((char) param[ 0 ].xword, fp) == EOF)
306 case 61 : /* writechar */
307 putc((char) param[ 0 ].xword, stdout);
310 case 62 : /* writeint(f) */
311 loadfile((word) WRITING, &t1, &t2, &fp);
312 if (t1 != TEXTF) errsignal(RTEILLIO);
313 writeint(param[ 0 ].xword, param[ 1 ].xword, fp);
316 case 63 : /* writeint */
317 writeint(param[ 0 ].xword, param[ 1 ].xword, stdout);
320 case 64 : /* writereal0(f) */
321 case 66 : /* writereal1(f) */
322 case 68 : /* writereal2(f) */
323 loadfile((word) WRITING, &t1, &t2, &fp);
324 if (t1 != TEXTF) errsignal(RTEILLIO);
325 writereal((double) param[ 0 ].xreal, param[ 1 ].xword,
326 param[ 2 ].xword, fp);
329 case 65 : /* writereal0 */
330 case 67 : /* writereal1 */
331 case 69 : /* writereal2 */
332 writereal((double) param[ 0 ].xreal, param[ 1 ].xword,
333 param[ 2 ].xword, stdout);
336 case 70 : /* writestring(f) */
337 loadfile((word) WRITING, &t1, &t2, &fp);
338 if (t1 != TEXTF) errsignal(RTEILLIO);
339 writestring(param[ 0 ].xword, param[ 1 ].xword, fp);
342 case 71 : /* writestring */
343 writestring(param[ 0 ].xword, param[ 1 ].xword, stdout);
346 case 72 : /* open temporary file */
347 genfileobj(TRUE , param[ 1 ].xword, tempfilename(),
348 ¶m[ 0 ].xvirt, &t1);
351 case 73 : /* open external file */
352 genfileobj(FALSE, param[ 1 ].xword, asciiz(¶m[ 2 ].xvirt),
353 ¶m[ 0 ].xvirt, &t1);
357 param[ 0 ].xbool = lbool(testeoln(stdin));
360 case 75 : /* eoln(f) */
361 loadfile((word) READING, &t1, &t2, &fp);
362 if (t1 != TEXTF) errsignal(RTEILLIO);
363 param[ 0 ].xbool = lbool(testeoln(fp));
366 case 76 : /* this coroutine */
367 loadvirt(param[ 0 ].xvirt,
368 thisp->prochead+M[ thisp->prochead ]+CHD);
371 case 77 : /* this process */
377 p.mark = thisp->mark;
378 mess2obj( thisp, &p, &v );
379 param[ 0 ].xvirt = v;
383 case 78 : /* reset:procedure(f:file) */
384 if (member(¶m[ 0 ].xvirt, &t2))
386 else errsignal(RTEREFTN);
389 case 79 : /* rewrite:procedure(f:file) */
390 if (member(¶m[ 0 ].xvirt, &t2))
392 else errsignal(RTEREFTN);
395 case 80 : /* unlink:procedure(f:file) */
396 delete(¶m[ 0 ].xvirt);
399 case 81 : /* seek:procedure(f:file, offset, base:integer) */
400 storevirt(param[ 0 ].xvirt, currfile);
401 loadfile((word) UPDATING, &t1, &t2, &fp);
402 if (t1 != DIRECT) errsignal(RTEILLIO);
403 if (fseek(fp, (long) param[ 1 ].xword, (int) param[ 2 ].xword))
407 case 82 : /* getrec(f, a, n) */
408 loadfile((word) UPDATING, &t1, &t2, &fp);
409 if (t1 != DIRECT) errsignal(RTEILLIO);
410 param[ 1 ].xword = directio(
418 case 83 : /* putrec(f, a, n) */
419 loadfile((word) UPDATING, &t1, &t2, &fp);
420 if (t1 != DIRECT) errsignal(RTEILLIO);
421 param[ 1 ].xword = directio(
429 case 84 : /* position:function(f:file):real */
430 storevirt(param[ 0 ].xvirt, currfile);
431 loadfile((word) UPDATING, &t1, &t2, &fp);
432 if (t1 != DIRECT) errsignal(RTEILLIO);
433 param[ 1 ].xword =(int) ftell(fp);
436 case 98 : /* memavail:function:integer */
437 param[ 0 ].xword = memavail();
440 case 99 : /* exec:function(c:arrayof char):integer */
441 cp = asciiz(¶m[ 0 ].xvirt);
442 param[ 1 ].xword = system(cp);
453 if (absent) errsignal(RTEUNSTP);