Mercurial > repo

comparison interps/c-intercal/src/cesspool.c @ 996:859f9b4339e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
1 /*****************************************************************************
2
3 NAME
4 cesspool.c -- storage management and runtime support for INTERCAL
5
6 LICENSE TERMS
7 Copyright (C) 1996 Eric S. Raymond
8
9 This program is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2 of the License, or
12 (at your option) any later version.
13
14 This program is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with this program; if not, write to the Free Software
21 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
22
23 ***************************************************************************/
24 /* LINTLIBRARY */
25 #include <stdio.h>
26 #include <stdlib.h>
27 #include <string.h>
28 #include <setjmp.h>
29 #include <limits.h>
30 #include <assert.h>
31
32 #include "config.h"
33 #ifdef HAVE_STDARG_H
34 #include <stdarg.h>
35 #else
36 #include <varargs.h>
37 #endif
38
39 #include "sizes.h"
40 /* AIS: To avoid a separate overloaded/nonoverloaded library, we import
41 the overloading defines here and ignore them if we don't need them. */
42 #define MULTITHREAD 0
43 #define OVEROPUSED 1
44 #include "abcess.h"
45 #include "ick_lose.h"
46
47 #include "numerals.c"
48
49 /* AIS: because BUFSIZ could theoretically be too large for an int... */
50 #if BUFSIZ < INT_MAX
51 #define INTBUFSIZ (int)BUFSIZ
52 #else
53 #define INTBUFSIZ (int)INT_MAX
54 #endif
55
56 /* and likewise, so that we can compare things to INT_MAX */
57 #ifndef min
58 #define min(x,y) ((x)>(y)?(y):(x))
59 #endif
60
61 /* and likewise, define SIZE_MAX */
62 #ifndef SIZE_MAX
63 #ifdef ULLONG_MAX
64 #define SIZE_MAX (sizeof(unsigned short )==sizeof(size_t)?(size_t) USHRT_MAX : \
65 sizeof(unsigned int )==sizeof(size_t)?(size_t) UINT_MAX : \
66 sizeof(unsigned long )==sizeof(size_t)?(size_t) ULONG_MAX : \
67 sizeof(unsigned long long)==sizeof(size_t)?(size_t)ULLONG_MAX : 0)
68 #else
69 #define SIZE_MAX (sizeof(unsigned short )==sizeof(size_t)?(size_t) USHRT_MAX : \
70 sizeof(unsigned int )==sizeof(size_t)?(size_t) UINT_MAX : \
71 sizeof(unsigned long )==sizeof(size_t)?(size_t) ULONG_MAX : 0)
72 #endif
73 #endif
74
75 /* AIS: These will be set to stdin/stdout at the first opportunity,
76 which is not necessarily here. The annotations are to tell splint
77 that we know what we're doing here with the assignments; the
78 set to stdin/stdout will be done whenever it's necessary.
79 */
80 /*@null@*/ FILE* ick_cesspoolin =0;
81 /*@null@*/ FILE* ick_cesspoolout=0;
82
83 /* AIS: To keep ld happy. This shouldn't ever actually get used, but
84 * give it a sane value just in case it does. (This is referenced by
85 * clc-cset.c, but due to the linking-in of the character sets
86 * themselves the reference should never be used.) */
87 /*@observer@*/ /*@dependent@*/ const char* ick_datadir=".";
88
89 /**********************************************************************
90 *
91 * The following functions manipulate the nexting stack
92 *
93 *********************************************************************/
94
95 unsigned* ick_next; /* AIS: now allocated by ick-wrap.c */
96 /*@null@*/ jmp_buf* ick_next_jmpbufs = NULL; /* AIS: for ick_ec, if needed */
97 int ick_nextindex = 0;
98
99 static int ick_clcsem = 0; /* AIS */
100
101 void ick_pushnext(unsigned n)
102 {
103 if (ick_nextindex < ick_MAXNEXT)
104 ick_next[ick_nextindex++] = n;
105 else
106 ick_lose(IE123, ick_lineno, (const char *)NULL);
107 }
108
109 unsigned int ick_popnext(unsigned int n)
110 {
111 ick_nextindex -= n;
112 if (ick_nextindex < 0) {
113 ick_nextindex = 0;
114 return (unsigned int)-1;
115 }
116 return ick_next[ick_nextindex];
117 }
118
119 /* AIS: This is not the ick_resume in ick_ec.h, which is a macro and therefore
120 technically speaking doesn't clash with this function as the header file
121 ick_ec.h isn't included. */
122 unsigned int ick_resume(unsigned int n)
123 {
124 if (n == 0)
125 {
126 ick_lose(IE621, ick_lineno, (const char *)NULL);
127 /*@-unreachable@*/ return 0; /*@=unreachable@*/
128 }
129 else if ((n = ick_popnext(n)) == (unsigned int)-1)
130 {
131 ick_lose(IE632, ick_lineno, (const char *)NULL);
132 /*@-unreachable@*/ return 0; /*@=unreachable@*/
133 }
134 return(n);
135 }
136
137 /**********************************************************************
138 *
139 * The following functions implement the INTERCAL I/O model
140 *
141 *********************************************************************/
142
143 unsigned int ick_pin(void)
144 {
145 char buf[INTBUFSIZ], *cp;
146 unsigned int result = 0;
147 size_t n;
148
149 assert(buf != NULL); /* AIS: splint seems unable of figuring this
150 out for itself */
151
152 if(!ick_cesspoolin) ick_cesspoolin=stdin; /* AIS */
153
154 if (fgets(buf, INTBUFSIZ, ick_cesspoolin) == (char *)NULL)
155 ick_lose(IE562, ick_lineno, (const char *)NULL);
156 n = strlen(buf) - 1;
157 if (n > 0 && buf[n-1] == '\r')
158 --n;
159 buf[n] = '\0';
160
161 if(ick_wimp_mode) {
162 result = (unsigned int)strtoul(buf, (char **)NULL, 10);
163 n = 1;
164 }
165 else
166 {
167 for(n=0,cp = strtok(buf, " ");cp;cp = strtok((char *)NULL, " "),n++)
168 {
169 int digit = -1;
170 const numeral *np;
171
172 for (np = ick_numerals; np < ick_numerals + sizeof(ick_numerals)/sizeof(numeral); np++)
173 if (strcmp(np->name, cp) == 0)
174 {
175 digit = np->value;
176 break;
177 }
178
179 if (digit == -1)
180 ick_lose(IE579, ick_lineno, cp);
181
182 if (result < 429496729 || (result == 429496729 && digit < 6))
183 result = result * 10 + digit;
184 else
185 ick_lose(IE533, ick_lineno, (const char *)NULL);
186 }
187 }
188 if (!n)
189 ick_lose(IE562, ick_lineno, (const char *)NULL);
190 if (result > (unsigned int)ick_Max_large)
191 ick_lose(IE533, ick_lineno, (const char *)NULL);
192 return(result);
193 }
194
195 /**********************************************************************
196 *
197 * Butchered Roman ick_numerals implemented by
198 * Michael Ernst, mernst@theory.lcs.mit.edu. May 7, 1990
199 *
200 * The INTERCAL manual hints that 3999 should translate to MMMIM
201 * (compare MMMCMXCIX) without specifying what the translation is.
202 * That may be a typo; in any case, this implementation isn't that
203 * butchered.
204 *
205 *********************************************************************/
206
207 #define MAXDIGITS 10 /* max base 10 digits */
208 #define MAXROMANS (MAXDIGITS*4+1) /* max chars in translation */
209
210 /*
211 * The ick_first column tells how many of the succeeding columns are used.
212 * The other columns refer to the columns of br_equiv and br_overbar.
213 */
214 static int ick_br_trans[10][5] =
215 {
216 {0, 0, 0, 0, 0},
217 {1, 0, 0, 0, 0},
218 {2, 0, 0, 0, 0},
219 {3, 0, 0, 0, 0},
220 {2, 1, 2, 0, 0}, /* or use {4, 0, 0, 0, 0} */
221 {1, 2, 0, 0, 0},
222 {2, 2, 1, 0, 0},
223 {3, 2, 1, 1, 0},
224 {4, 2, 1, 1, 1},
225 {2, 1, 3, 0, 0}
226 };
227
228 /*
229 * butcher places in the string result the "butchered" Roman numeral for val.
230 * This string should be printed at the beginning of a line; it spans two
231 * lines and already contains newlines.
232 *
233 * 11/24/91 LHH: Removed unnecessary final newline.
234 */
235
236 static void butcher(unsigned long val, /*@out@*/ char *result)
237 {
238 int i, j;
239 int digitsig, digitval;
240 char res[MAXROMANS], ovb[MAXROMANS];
241
242 /* We need FOUR columns because of the odd way that M and I interact. */
243 static const char br_equiv[MAXDIGITS][4] =
244 {
245 {'I', 'I', 'V', 'X'}, {'X', 'X', 'L', 'C'},
246 {'C', 'C', 'D', 'M'}, {'M', 'I', 'V', 'X'},
247 {'X', 'X', 'L', 'C'}, {'C', 'C', 'D', 'M'},
248 {'M', 'i', 'v', 'x'}, {'x', 'x', 'l', 'c'},
249 {'c', 'c', 'd', 'm'}, {'m', 'i', 'v', 'x'},
250 };
251
252 static const char br_overbar[MAXDIGITS][4] =
253 {
254 {' ', ' ', ' ', ' '},
255 {' ', ' ', ' ', ' '},
256 {' ', ' ', ' ', ' '},
257 {' ', '_', '_', '_'},
258 {'_', '_', '_', '_'},
259 {'_', '_', '_', '_'},
260 {'_', ' ', ' ', ' '},
261 {' ', ' ', ' ', ' '},
262 {' ', ' ', ' ', ' '},
263 {' ', '_', '_', '_'},
264 };
265
266 if (val == 0)
267 /* Final newline will be added by puts.
268 (void) strcpy(result, "_\n \n");
269 */
270 (void) strcpy(result, "_\n");
271 else
272 {
273 res[MAXROMANS-1] = '\0';
274 ovb[MAXROMANS-1] = '\0';
275 i = MAXROMANS-1;
276
277 /* the significance of the current digit is 10 ** digitsig */
278 for (digitsig = 0; (digitsig < MAXDIGITS) && (val > 0); digitsig++)
279 {
280 digitval = (int)(val % 10);
281 for (j = ick_br_trans[digitval][0]; j > 0; j--)
282 {
283 /* printf("In j loop: %d %d\n", j, i); */
284 res[--i] = br_equiv[digitsig][ick_br_trans[digitval][j]];
285 ovb[i] = br_overbar[digitsig][ick_br_trans[digitval][j]];
286 }
287 val = val / 10;
288 }
289
290 j = i;
291 while ((*result++ = ovb[j++]) != '\0')
292 continue;
293 *--result = '\n';
294
295 j = i;
296 while ((*++result = res[j++]) != '\0')
297 continue;
298 /* Final newline will be added by puts.
299 *result++ = '\n';
300 */
301 *result = '\0';
302 }
303 }
304
305 void ick_clockface(ick_bool mode)
306 /* enable or disable ick_clockface mode (output IIII instead of IV) */
307 {
308 if (mode)
309 {
310 /* ick_clockface mode */
311 ick_br_trans[4][0] = 4;
312 ick_br_trans[4][1] = 0;
313 ick_br_trans[4][2] = 0;
314 }
315 else
316 {
317 /* normal mode */
318 ick_br_trans[4][0] = 2;
319 ick_br_trans[4][1] = 1;
320 ick_br_trans[4][2] = 2;
321 }
322 }
323
324 void ick_setclcsemantics(ick_bool mode) /* AIS: CLC-INTERCAL semantics mode? */
325 {
326 ick_clcsem=mode;
327 }
328
329 void ick_pout(unsigned int val)
330 /* output in `butchered' Roman ick_numerals; see manual, part 4.4.13 */
331 {
332 char result[2*MAXROMANS+1];
333
334 if(!ick_cesspoolout) ick_cesspoolout=stdout; /* AIS */
335
336 if(ick_wimp_mode) {
337 (void) fprintf(ick_cesspoolout,"%u\n",val);
338 }
339 else {
340 butcher(val, result);
341 (void) fprintf(ick_cesspoolout,"%s\n",result);
342 }
343 (void) fflush(ick_cesspoolout);
344 }
345
346 /**********************************************************************
347 *
348 * AIS: CLC-INTERCAL bitwise I/O, only used in CLC-INTERCAL semantics
349 * mode. The I/O is done in extended Baudot for a tail ick_array, or in
350 * mingled form for a hybrid ick_array; for the Baudot, we rely on
351 * clc-cset.c and on the Baudot and Latin-1 character sets that are
352 * linked to libick.a (or libickmt.a), so the final executable doesn't
353 * reference the compiler's libraries. clc-cset.c is designed to
354 * handle this all transparently, though, so we don't have to worry
355 * about the details. I wrote the next two functions.
356 *
357 **********************************************************************/
358
359 /* AIS: From clc-cset.c */
360 extern int ick_clc_cset_convert(const char* in, /*@partial@*/ char* out, const char* incset,
361 const char* outcset, int padstyle, size_t outsize,
362 /*@null@*/ FILE* errsto);
363
364 static void clcbinin(unsigned int type, ick_array *a, ick_bool forget)
365 {
366 size_t i;
367 int ti;
368 char* buf, *tempcp;
369 /* Allocating one byte per element in the ick_array must be enough,
370 * because the Baudot version cannot possibly be shorter than the
371 * original Latin-1, plus one for the terminating NUL. There is one
372 * potential problem, which is that fgets takes an int for the
373 * number of bytes to read, so we cap the number of bytes to read
374 * at INT_MAX and hope that's enough. */
375 i=a->dims[0]; /* we already know that there's 1 dim only */
376 if(SIZE_MAX/6-2<=a->dims[0])
377 ick_lose(IE252, ick_lineno, (const char*)NULL); /* size is too large */
378 if(!i) i=1;
379 buf=malloc(i+1);
380 if(!buf) ick_lose(IE252, ick_lineno, (const char*)NULL);
381 if(!ick_cesspoolin) ick_cesspoolin=stdin;
382 if(!fgets(buf,(int)(min(a->dims[0],(size_t)INT_MAX)),ick_cesspoolin))
383 strcpy(buf,"\n"); /* EOF inputs the null string in CLC-INTERCAL */
384 tempcp=strrchr(buf,'\n'); /* still working in ASCII at this point */
385 if(!tempcp) /* input too long for the ick_array is an error */
386 {
387 free(buf);
388 ick_lose(IE241, ick_lineno, (const char*)NULL);
389 }
390 *tempcp='\0'; /* chomp the final newline */
391 tempcp=malloc(6*i+12); /* to be on the safe side, even though
392 * Baudot doesn't use 16-byte chars */
393 if(!tempcp) ick_lose(IE252, ick_lineno, (const char*)NULL);
394 /* Zero the ick_array now. */
395 i=a->dims[0];
396 if(!forget) while(i--)
397 if(type==ick_TAIL)
398 a->data.tail[i]=0;
399 else
400 a->data.hybrid[i]=0;
401 ti=ick_clc_cset_convert(buf,tempcp,"latin1","baudot",2,6*a->dims[0]+12,(FILE*)0);
402 /* Negative ti ought to be impossible here; check anyway, and cause
403 * an internal error if it has happened. */
404 if(ti<0) ick_lose(IE778, ick_lineno, (const char*)NULL);
405 i=(size_t)ti;
406 if(i>a->dims[0]) ick_lose(IE241, ick_lineno, (const char*)0);
407 if(!forget) while(i--)
408 if(type==ick_TAIL)
409 a->data.tail[i]=(ick_type16)tempcp[i]+
410 (ick_type16)((rand()%256)*256);
411 else
412 a->data.hybrid[i]=(ick_type32)tempcp[i]+
413 (ick_type32)((rand()%256)*256);
414 free(tempcp);
415 free(buf);
416 }
417
418 static void clcbinout(unsigned int type, const ick_array* a)
419 {
420 size_t i;
421 int ti;
422 char* buf, *tempcp;
423 if(SIZE_MAX/6-2<=a->dims[0])
424 ick_lose(IE252, ick_lineno, (const char*)NULL); /* size is too large */
425 buf=malloc(a->dims[0]+1);
426 if(!buf) ick_lose(IE252, ick_lineno, (const char*) NULL);
427 i=0; tempcp=buf;
428 while(i<a->dims[0])
429 {
430 /* Values above 31 are invalid in Baudot, so cap them at 33 to
431 avoid integer wraparound trouble. */
432 if(type==ick_TAIL)
433 *tempcp=(char)min(33,a->data.tail[i]);
434 else
435 *tempcp=(char)min(33,a->data.hybrid[i]);
436 i++;
437 if(*tempcp!='\0')
438 tempcp++; /* NULs are ignored for some reason, but
439 * that's the behaviour the CLC-INTERCAL
440 * specs specify */
441 }
442 *tempcp='\0';
443 /* tempcp is definitely overkill here, but the *6+6 rule is being
444 * obeyed because that way the code is robust against any future
445 * changes in character sets. */
446 tempcp=malloc(a->dims[0]*6+12);
447 if(!tempcp) ick_lose(IE252, ick_lineno, (const char*) NULL);
448 ti=ick_clc_cset_convert(buf,tempcp,"baudot","latin1",0,6*a->dims[0]+12,(FILE*)0);
449 if(ti<0) ick_lose(IE778, ick_lineno, (const char*)NULL);
450 i=(size_t)ti;
451 tempcp[i]='\0';
452 /* CLC-INTERCAL bails out on invalid characters. C-INTERCAL uses
453 * instead the behaviour of replacing them with character code 26.
454 * (This is actually the purpose of character code 26 in ASCII, I
455 * think, although this is derived from memory; I don't know of any
456 * other system that uses it for this purpose, though, and the
457 * ability to confuse Windows with it is worth what might be lost
458 * through standards compliance, because Windows nonstandardly
459 * treats it as an EOF character.) */
460 while(i--) if(tempcp[i] == '\0') tempcp[i]='\x1a';
461 if(!ick_cesspoolout) ick_cesspoolout=stdout;
462 fprintf(ick_cesspoolout,"%s\n",tempcp);
463 (void) fflush(ick_cesspoolout);
464 free(tempcp);
465 free(buf);
466 }
467
468 /**********************************************************************
469 *
470 * The following two routines implement bitwise I/O. They assume
471 * 8 bit characters, but there's no reason more general versions
472 * could not be written.
473 *
474 *********************************************************************/
475
476 void ick_binin(unsigned int type, ick_array *a, ick_bool forget)
477 {
478 static int lastin = 0;
479 int c, v;
480 size_t i;
481
482 if (a->rank != 1)
483 ick_lose(IE241, ick_lineno, (const char *)NULL);
484
485 if(!ick_cesspoolin) ick_cesspoolin=stdin; /* AIS */
486
487 if(ick_clcsem) {clcbinin(type, a, forget); return;} /* AIS */
488
489 for (i = 0 ; i < a->dims[0] ; i++) {
490 v = ((c=fgetc(ick_cesspoolin)) == EOF) ? 256 :
491 ((unsigned)c - lastin) % 256;
492 lastin = c;
493 if (!forget) {
494 if (type == ick_TAIL)
495 a->data.tail[i] = (ick_type16) v;
496 else
497 a->data.hybrid[i] = (ick_type32) v;
498 }
499 }
500 }
501
502 void ick_binout(unsigned int type, const ick_array *a)
503 {
504 static unsigned int lastout = 0;
505 unsigned int c;
506 size_t i;
507
508 if (a->rank != 1)
509 ick_lose(IE241, ick_lineno, (const char *)NULL);
510
511 if(!ick_cesspoolout) ick_cesspoolout=stdout; /* AIS */
512
513 if(ick_clcsem) {clcbinout(type, a); return;} /* AIS */
514
515 for (i = 0 ; i < a->dims[0] ; i++) {
516 if (type == ick_TAIL)
517 c = lastout - a->data.tail[i];
518 else
519 c = lastout - a->data.hybrid[i];
520 lastout = c;
521 c = (c & 0x0f) << 4 | (c & 0xf0) >> 4;
522 c = (c & 0x33) << 2 | (c & 0xcc) >> 2;
523 c = (c & 0x55) << 1 | (c & 0xaa) >> 1;
524 (void) fputc((int)c,ick_cesspoolout);
525 if (c == 10 /* \n in INTERCAL */ || /* AIS */ ick_instapipe)
526 (void) fflush(ick_cesspoolout);
527 }
528 }
529
530 /**********************************************************************
531 *
532 * The following assignment function performs IGNORE and type checks
533 *
534 *********************************************************************/
535
536 unsigned int ick_assign(char *dest, unsigned int type, ick_bool forget,
537 unsigned int value)
538 {
539 unsigned int retval = 0;
540 if (type == ick_ONESPOT || type == ick_TAIL) {
541 if (value > (unsigned int)ick_Max_small)
542 ick_lose(IE275, ick_lineno, (const char *)NULL);
543 if (forget)
544 retval = value;
545 else {
546 retval = *(ick_type16*)dest;
547 *(ick_type16*)dest = (ick_type16) value;
548 }
549 }
550 else if (type == ick_TWOSPOT || type == ick_HYBRID) {
551 if (forget)
552 retval = value;
553 else {
554 retval = *(ick_type32*)dest;
555 *(ick_type32*)dest = value;
556 }
557 }
558 return retval;
559 }
560
561 /**********************************************************************
562 *
563 * The following functions implement the INTERCAL ick_array model
564 * If HAVE_STDARG_H is defined, stdarg is used, otherwise varargs.
565 *
566 *********************************************************************/
567
568
569 #ifdef HAVE_STDARG_H
570 /*@dependent@*/ void *ick_aref(unsigned int type, ...)
571 #else
572 /*@dependent@*/ void *ick_aref(va_alist) va_dcl
573 #endif
574 /* return a pointer to the ick_array location specified by args */
575 {
576 #ifndef HAVE_STDARG_H
577 unsigned int type;
578 #endif
579 ick_array *a;
580 unsigned int v;
581 va_list ap;
582 size_t address = 0;
583 unsigned int i;
584
585 #ifdef HAVE_STDARG_H
586 va_start(ap, type);
587 #else
588 va_start(ap);
589 type = va_arg(ap, unsigned int);
590 #endif
591 a = va_arg(ap, ick_array*);
592
593 if (va_arg(ap, unsigned int) != a->rank)
594 ick_lose(IE241, ick_lineno, (const char *)NULL);
595
596 for (i = 0 ; i < a->rank ; i++) {
597 v = va_arg(ap, unsigned int);
598 if (v == 0 || (size_t)v > a->dims[i])
599 ick_lose(IE241, ick_lineno, (const char *)NULL);
600 address = address * a->dims[i] + v - 1;
601 }
602
603 va_end(ap);
604
605 if (type == ick_TAIL)
606 return (void*)&(a->data.tail[address]);
607 else
608 return (void*)&(a->data.hybrid[address]);
609 }
610
611 #ifdef HAVE_STDARG_H
612 void ick_resize(unsigned int type, ...)
613 #else
614 void ick_resize(va_alist) va_dcl
615 #endif
616 /* ick_resize an ick_array to the given shape */
617 {
618 #ifndef HAVE_STDARG_H
619 unsigned int type;
620 #endif
621 ick_array *a;
622 ick_bool forget;
623 unsigned int i, r;
624 size_t v;
625 va_list ap;
626 int prod = 1;
627
628 #ifdef HAVE_STDARG_H
629 va_start(ap, type);
630 #else
631 va_start(ap);
632 type = va_arg(ap, unsigned int);
633 #endif
634 a = va_arg(ap, ick_array*);
635 forget = va_arg(ap, ick_bool);
636
637 /* AIS: a->dims is no longer initialised. So initialise it here if
638 it isn't already initialised, with an annotation to explain that
639 we aren't freeing the old pointer (because it was never malloced in
640 the first place and is probably invalid anyway.) */
641 /*@-mustfreeonly@*/
642 if (!a->rank) a->dims = 0;
643 /*@-mustfreeonly@*/
644
645 r = va_arg(ap, unsigned int);
646 if (!forget) {
647 a->rank = r;
648 if (a->dims)
649 free((char*)a->dims);
650 a->dims = malloc(a->rank * sizeof(*(a->dims)));
651 if (a->dims == NULL)
652 ick_lose(IE241, ick_lineno, (const char *)NULL);
653 }
654
655 for (i = 0 ; i < r ; i++) {
656 v = va_arg(ap, size_t);
657 if (v == 0)
658 ick_lose(IE240, ick_lineno, (const char *)NULL);
659 if (!forget) {
660 assert(a->dims != NULL); /* AIS: it isn't, because !forget, but
661 splint doesn't know that */
662 a->dims[i] = v;
663 prod *= v;
664 }
665 }
666
667 if (!forget) {
668 if (type == ick_TAIL) {
669 if (a->data.tail)
670 free((char *)a->data.tail);
671 a->data.tail = (ick_type16*)malloc(prod * sizeof(ick_type16));
672 if (a->data.tail == NULL)
673 ick_lose(IE241, ick_lineno, (const char *)NULL);
674 }
675 else {
676 if (a->data.hybrid)
677 free((char *)a->data.hybrid);
678 a->data.hybrid = (ick_type32*)malloc(prod * sizeof(ick_type32));
679 if (a->data.hybrid == NULL)
680 ick_lose(IE241, ick_lineno, (const char *)NULL);
681 }
682 }
683
684 va_end(ap);
685 }
686
687 /**********************************************************************
688 *
689 * The following functions implement save/retrieve
690 *
691 *********************************************************************/
692
693 /*@null@*/ ick_stashbox *ick_first; /* AIS: made non-static so it can be seen by unravel.c */
694
695 void ick_stashinit(void)
696 {
697 ick_first = NULL;
698 }
699
700 static /*@null@*/ ick_stashbox *fetch(unsigned int type, unsigned int index)
701 /* find a stashed variable in the save stack and extract it */
702 {
703 ick_stashbox **pp = &ick_first, *sp = ick_first;
704
705 while (sp != NULL && (sp->type != type || sp->index != index)) {
706 pp = &sp->ick_next;
707 sp = sp->ick_next;
708 }
709 if (sp)
710 *pp = sp->ick_next;
711
712 /* The annotation here is because Splint can't figure out that
713 ick_first can be modified via pp, and because this function
714 is the place where storage marked 'dependent' is initialised
715 and deinitialised. */
716 /*@-globstate@*/ /*@-dependenttrans@*/
717 return (sp);
718 /*@=globstate@*/ /*@=dependenttrans@*/
719 }
720
721 void ick_stash(unsigned int type, unsigned int index, void *from, ick_overop* oo)
722 /* stash away the variable's value */
723 {
724 /*@-nullassign@*/
725 ick_overop dummyoo;
726 /*@=nullassign@*/
727 /* create a new ick_stashbox and push it onto the stack */
728 ick_stashbox *sp;
729 dummyoo.get = (ick_type32 (*)(ick_type32))NULL;
730 dummyoo.set = (void (*)(ick_type32, void(*)()))NULL;
731 sp = (ick_stashbox*)malloc(sizeof(ick_stashbox));
732 if (sp == NULL) ick_lose(IE222, ick_lineno, (const char *)NULL);
733 sp->ick_next = ick_first;
734 ick_first = sp;
735
736 /* store the variable in it */
737 ick_first->type = type;
738 ick_first->index = index;
739 if(oo) ick_first->overloadinfo=oo[index]; /* AIS */
740 else ick_first->overloadinfo=dummyoo; /* AIS */
741 if (type == ick_ONESPOT)
742 {
743 memcpy(&ick_first->save.onespot, from, sizeof(ick_type16));
744 }
745 else if (type == ick_TWOSPOT)
746 memcpy(&ick_first->save.twospot, from, sizeof(ick_type32));
747 else if (type == ick_TAIL || type == ick_HYBRID) {
748 ick_array *a = (ick_array*)from;
749 int prod;
750 unsigned int i;
751 ick_first->save.a = (ick_array*)malloc(sizeof(ick_array));
752 if (ick_first->save.a == NULL) ick_lose(IE222, ick_lineno, (const char *)NULL);
753 ick_first->save.a->rank = a->rank;
754 ick_first->save.a->dims = malloc(a->rank * sizeof(*(ick_first->save.a->dims)));
755 if (ick_first->save.a->dims == NULL) ick_lose(IE222, ick_lineno, (const char *)NULL);
756 memcpy(ick_first->save.a->dims, a->dims,
757 a->rank * sizeof(*(a->dims)));
758 prod = a->rank ? 1 : 0;
759 for (i = 0 ; i < a->rank ; i++) {
760 prod *= a->dims[i];
761 }
762 if (type == ick_TAIL) {
763 ick_first->save.a->data.tail =
764 (ick_type16*)malloc(prod * sizeof(ick_type16));
765 if (ick_first->save.a->data.tail == NULL) ick_lose(IE222, ick_lineno, (const char *)NULL);
766 memcpy(ick_first->save.a->data.tail,
767 a->data.tail, prod * sizeof(ick_type16));
768 }
769 else {
770 ick_first->save.a->data.hybrid =
771 (ick_type32*)malloc(prod * sizeof(ick_type32));
772 if (ick_first->save.a->data.hybrid == NULL) ick_lose(IE222, ick_lineno, (const char *)NULL);
773 memcpy(ick_first->save.a->data.hybrid,
774 a->data.hybrid, prod * sizeof(ick_type32));
775 }
776 }
777 return;
778 }
779
780 void ick_retrieve(void *to, unsigned int type, unsigned int index,
781 ick_bool forget, ick_overop* oo)
782 /* restore the value of a variable from the save stack */
783 {
784 ick_stashbox *sp;
785
786 if ((sp = fetch(type, index)) == (ick_stashbox *)NULL)
787 ick_lose(IE436, ick_lineno, (const char *)NULL);
788 else if (!forget) {
789 if(oo) oo[index]=sp->overloadinfo; /* AIS */
790 if (type == ick_ONESPOT)
791 memcpy(to, (const char *)&sp->save.onespot, sizeof(ick_type16));
792 else if (type == ick_TWOSPOT)
793 memcpy(to, (const char *)&sp->save.twospot, sizeof(ick_type32));
794 else if (type == ick_TAIL || type == ick_HYBRID) {
795 ick_array *a = (ick_array*)to;
796 /*@-branchstate@*/ /* it's a union, so one valid is correct */
797
798 if (a->rank) {
799 free(a->dims);
800 if (type == ick_TAIL)
801 free(a->data.tail);
802 else
803 free(a->data.hybrid);
804 memcpy(to, (const char*)sp->save.a, sizeof(ick_array));
805 }
806 /*@=branchstate@*/
807 /* AIS: there isn't a memory leak here, because we memcpyd the
808 pointers elsewhere and so they are yet accessible. You can't
809 expect Splint to figure out what's going on there, though, thus
810 the annotations. */
811 /*@-compdestroy@*/
812 free(sp->save.a);
813 /*@=compdestroy@*/
814 }
815 }
816 else if (type == ick_TAIL || type == ick_HYBRID) {
817 free(sp->save.a->dims);
818 if (type == ick_TAIL)
819 free(sp->save.a->data.tail);
820 else
821 free(sp->save.a->data.hybrid);
822 free(sp->save.a);
823 }
824 free(sp);
825 }
826
827 /**********************************************************************
828 *
829 * The following function is used for random decision making
830 *
831 *********************************************************************/
832
833 unsigned int ick_roll(unsigned int n)
834 /* return ick_TRUE on n% chance, ick_FALSE otherwise */
835 {
836 #ifdef USG
837 return((unsigned int)(lrand48() % 100) < n);
838 #else
839 return((unsigned int)(rand() % 100) < n);
840 #endif /* UNIX */
841 }
842
843 /**********************************************************************
844 *
845 * AIS: This function is called when two COME FROMs reference the same
846 * line at runtime. ick_multicome0 is used in a non-multithread
847 * program; it produces an error. For multicome1, see unravel.c.
848 *
849 *********************************************************************/
850
851 int ick_multicome0(int errlineno, jmp_buf pc)
852 {
853 /*@-noeffect@*/
854 (void) pc; /* it's ignored by this function */
855 /*@=noeffect@*/
856 ick_lose(IE555, errlineno, (const char *) NULL);
857 /* this line number is quite possibly going to be wildly inaccurate */
858 /*@-unreachable@*/
859 return 0;
860 /*@=unreachable@*/
861 }
862
863 /**********************************************************************
864 *
865 * AIS: The next two functions are mine, and handle CREATE statements.
866 *
867 **********************************************************************/
868
869 struct ick_jictype
870 {
871 /*@observer@*/ const char* sig; /* a shallow copy of a constant string */
872 unsigned long target;
873 /*@null@*/ /*@only@*/ struct ick_jictype* next;
874 };
875
876 /*@null@*/ /*@only@*/ static struct ick_jictype* jiclist = NULL;
877
878 /* Return a jic entry that matches the requested signature exactly,
879 creating one if there isn't one yet. */
880 static struct ick_jictype* jicextract(/*@observer@*/ const char* sig)
881 {
882 struct ick_jictype* jicptr = jiclist;
883 while(jicptr)
884 {
885 if(strcmp(jicptr->sig,sig)==0) return jicptr;
886 if(jicptr->next != NULL) jicptr = jicptr->next;
887 else break;
888 }
889 if(!jicptr)
890 {
891 jiclist=malloc(sizeof *jiclist);
892 jicptr=jiclist;
893 }
894 else
895 {
896 jicptr->next=malloc(sizeof *jiclist);
897 jicptr=jicptr->next;
898 }
899 jicptr->next = NULL;
900 jicptr->sig = sig;
901 jicptr->target = 0;
902 return jicptr;
903 }
904
905 void ick_registercreation(const char* sig, unsigned long target)
906 {
907 jicextract(sig)->target=target;
908 }
909
910 unsigned long ick_jicmatch(const char* sig)
911 {
912 return jicextract(sig)->target;
913 }
914
915 /* AIS: Used by the JIC code to error out when attempting to access an array */
916 ick_type32 ick_ieg277(ick_type32 ignored)
917 {
918 /*@-noeffect@*/
919 (void) ignored;
920 /*@=noeffect@*/
921 ick_lose(IE277, ick_lineno, (const char*) NULL);
922 }
923
924 void ick_ies277(ick_type32 ignored, void(*ignored2)())
925 {
926 /*@-noeffect@*/
927 (void) ignored;
928 (void) ignored2;
929 /*@=noeffect@*/
930 ick_lose(IE277, ick_lineno, (const char*) NULL);
931 }
932
933 /* cesspool.c ends here */