|
996
|
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 */
|
