1 /*
2 * $Id: yio.c,v 1.4 2010-02-28 21:32:23 dhmunro Exp $
3 * Implement Yorick I/O functions.
4 */
5 /* Copyright (c) 2005, The Regents of the University of California.
6 * All rights reserved.
7 * This file is part of yorick (http://yorick.sourceforge.net).
8 * Read the accompanying LICENSE file for details.
9 */
10
11 #include "yio.h"
12 #include "defmem.h"
13
14 #include "ydata.h"
15 #include "pstdlib.h"
16 #include "play.h"
17
18 #include <string.h>
19
20 /* Print action defined here */
21 extern VMaction Print;
22
23 extern UnaryOp EvalFN, EvalBI, eval_auto; /* required by Print */
24 extern BuiltIn Y_print, Y_print_format, Y_rangeof;
25
26 /* required by print() called as function */
27 extern Array *GrowArray(Array *array, long extra);
28
29 extern char *MakeErrorLine(long lineNumber, const char *filename);
30
31 /* Non-blocking input tester defined in sysdep.c */
32 extern int YstdinNB(int noWait);
33
34 /*--------------------------------------------------------------------------*/
35
36 extern char *GetRFName(RangeFunc *rfTarget);
37
38 extern long ReopenSource(long index, int notExtern, long isrc);
39 extern int YpParse(void *func);
40
41 /*--------------------------------------------------------------------------*/
42
43 /* Yorick wrappers for fgets, feof, and ferror. */
44
Yfgets(char * s,int n,p_file * stream)45 char *Yfgets(char *s, int n, p_file *stream)
46 {
47 if (stream) return p_fgets(stream, s, n);
48 YError("(BUG) Yfgets with stream==0"); return 0;
49 }
50
Yfeof(p_file * stream)51 int Yfeof(p_file *stream)
52 {
53 if (stream) return p_feof(stream);
54 YError("(BUG) Yfeof with stream==0"); return 0;
55 }
56
Yferror(p_file * stream)57 int Yferror(p_file *stream)
58 {
59 if (stream) return p_ferror(stream);
60 YError("(BUG) Yferror with stream==0"); return 0;
61 }
62
YDPrompt(char * s)63 int YDPrompt(char *s)
64 {
65 p_stdout(s);
66 return 0;
67 }
68
YDputsOut(char * s)69 int YDputsOut(char *s)
70 {
71 p_stdout(s);
72 p_stdout("\n");
73 return 0;
74 }
75
YDputsErr(char * s)76 int YDputsErr(char *s)
77 {
78 p_stderr(s);
79 p_stderr("\n");
80 return 0;
81 }
82
83 int (*YPrompt)(char *s)= &YDPrompt;
84 int (*YputsOut)(char *s)= &YDputsOut;
85 int (*YputsErr)(char *s)= &YDputsErr;
86
87 /*--------------------------------------------------------------------------*/
88 /* Yorick interface to gets() allows for virtually unlimited length lines.
89 The price is the necessity of passing a struct* instead of a simple
90 char*... The case of file==0 is special -- file==0 means "stdin",
91 but Yorick allows for the possibility of more complex arrangements
92 for "stdin", including the possibility that keyboard input stream
93 is not coming from a standard C library input stream at all (it could
94 come, e.g., from some sort of X window message). */
95 #define MIN_LINE 256
96 #define BIG_LINE 1024
97 #define MAX_LINE 16384
98 #define INC_LINE 256
99
100 char *
Ygets(YgetsLine * getsLine,p_file * file)101 Ygets(YgetsLine *getsLine, p_file *file)
102 {
103 char *line = getsLine->line;
104 int ateof, n, maxChars = getsLine->max;
105
106 if (!file) YError("(BUG) file==0 to Ygets no longer legal");
107
108 if (maxChars<MIN_LINE || maxChars>BIG_LINE) {
109 p_free(line);
110 getsLine->line = line = p_malloc(MIN_LINE+1);
111 getsLine->max = maxChars = MIN_LINE;
112 line[maxChars] = '\0'; /* just in case... */
113 }
114
115 /* Take care not to try to read a stream that has already returned EOF. */
116 if (Yfeof(file) || !Yfgets(line, maxChars+1, file)) goto abort;
117 ateof = Yfeof(file);
118 if (!ateof && Yferror(file)) goto abort;
119
120 n = strlen(line);
121 while (line[n-1]!='\n' && !ateof) {
122 if (maxChars>=MAX_LINE) goto abort;
123 if (n >= maxChars-8) {
124 /* on any reasonable file system, n == maxChars here
125 * one some massively parallel file systems, however, fgets can
126 * return before end-of-line even though not at end-of-file
127 * - hence fgets should always be called in a loop until either
128 * \n or EOF
129 */
130 char *prev = line;
131 getsLine->line = line = p_malloc(maxChars+INC_LINE+1);
132 strcpy(line, prev);
133 p_free(prev);
134 getsLine->max = (maxChars += INC_LINE);
135 line[maxChars] = '\0'; /* just in case... */
136 }
137
138 /* EOF is possible, in which case Yfgets returns 0 (ignored here)
139 and leaves line unmodified. The following strlen is guaranteed
140 to return 0, and the loop terminates on the ateof test above. */
141 Yfgets(&line[n], maxChars+1-n, file);
142 ateof = Yfeof(file);
143 if (!ateof && Yferror(file)) goto abort;
144 n += strlen(&line[n]); /* faster than n= strlen(line) */
145 }
146
147 if (line[n-1]=='\n') line[--n] = '\0';
148 getsLine->n = n;
149 return line;
150
151 abort:
152 /* If neither Yferror(file) nor Yfeof(file), then line-too-long abort. */
153 if (maxChars>MIN_LINE) {
154 p_free(line);
155 getsLine->line = line = p_malloc(MIN_LINE+1);
156 getsLine->max = maxChars = MIN_LINE;
157 }
158 line[0] = '\0';
159 getsLine->n = 0;
160 return 0;
161 }
162
163 /*--------------------------------------------------------------------------*/
164
165 /* Scan for C-style escape sequences in quoted strings (e.g.- \n, \t),
166 returning the (single character) value of the escape sequence, and,
167 if the 2nd parameter is non-0, the character which stopped the scan.
168 Thus, if s=="tXYZ", then YpEscapeSeq returns 9 (ASCII tab), and
169 endp=="XYZ"; the same results would obtain if s=="009XYZ". */
YpEscapeSeq(const char * s,char ** endp)170 int YpEscapeSeq(const char *s, char **endp)
171 {
172 unsigned char c= *s++;
173 int val;
174
175 /* 1, 2, or 3 octal digits */
176 if (c<='7' && c>='0') {
177 int i= 2;
178 val= c-'0';
179 while ((c=*s)<='7' && c>='0' && i--) {
180 val<<= 3;
181 val|= c-'0';
182 s++;
183 }
184
185 /* any number of hex digits (according to appendix A2.5.2 2nd ed K+R) */
186 } else if (c=='x') {
187 int isD, isU= 0;
188 val= 0;
189 while ((isD= ((c= *s)<='9' && c>='0')) ||
190 (isU= (c<='F' && c>='A')) ||
191 (c<='f' && c>='a')) {
192 val<<= 4;
193 if (isD) val|= c-'0';
194 else if (isU) val|= c-('A'-10);
195 else val|= c-('a'-10);
196 s++;
197 }
198
199 /* symbolic escapes in rough order of frequency I use them */
200 } else if (c=='n') val= '\n';
201 else if (c=='t') val= '\t';
202 else if (c=='a') val= '\a';
203 else if (c=='f') val= '\f';
204 else if (c=='r') val= '\r';
205 else if (c=='v') val= '\v';
206 else if (c=='b') val= '\b';
207
208 /* Note that \ ? ' and " are just self-insertion like anything else. */
209 else val= c;
210
211 if (endp) *endp= (char *)s; /* sigh */
212 return val;
213 }
214
215 /*--------------------------------------------------------------------------*/
216
217 extern UnaryOp PrintC, PrintS, PrintI, PrintL, PrintF, PrintD, PrintZ,
218 PrintQ, PrintP, PrintSI, PrintR, PrintVD, PrintSD, PrintFN, PrintBI,
219 PrintIO;
220
221 int printLength= 79; /* maximum number of characters to put on a line */
222 long maxPrintLines= 5000;
223
224 static char nBuffer[120]; /* buffer to hold numbers from sprintf */
225
226 static int (*RawPrinter)(char *s);
227 extern int PutsAsArray(char *s);
228
229 static void (*PrintRaw)(Operand *at);
230 static void PrintRawC(Operand *at);
231 static void PrintRawS(Operand *at);
232 static void PrintRawI(Operand *at);
233 static void PrintRawL(Operand *at);
234 static void PrintRawF(Operand *at);
235 static void PrintRawD(Operand *at);
236 static void PrintRawZ(Operand *at);
237 static void PrintRawQ(Operand *at);
238 static void PrintRawP(Operand *at);
239 static void PrintRawSI(Operand *at);
240
241 static void PrintArray(Operand *at);
242
243 static char *GetTempBuffer(long len);
244 static void ClearTempBuffer(int force);
245
246 static void PrintDims(Dimension *dims);
247 static int PDRecurse(Dimension *dims, long *length, int last);
248
y_setup_func_hack(Operand * op)249 void y_setup_func_hack(Operand *op)
250 {
251 YError("bad data type for array index");
252 }
253
254 /* Print calls functions with no arguments, or prints anything else using
255 YputsOut. */
Print(void)256 void Print(void)
257 {
258 Operand op;
259 P_SOFTFPE_TEST;
260 sp->ops->FormOperand(sp, &op);
261 if (op.ops->Setup == &y_setup_func_hack) {
262 /* put operand into bogus form expected by Eval (see Eval in ops3.c) */
263 op.references= 0; /* intentionally misused */
264 op.ops->Eval(&op);
265 } else {
266 PrintInit(YputsOut);
267 op.ops->Print(&op);
268 /* Drop(1);
269 Print will be followed by DropTop so that CalledAsSubroutine always
270 works. See parse.c. */
271 ForceNewline();
272 }
273 }
274
275 /* Y_print is a built in function which prints each of its arguments
276 in turn in the manner of Print if called as a function, or returns a
277 string vector if called as a function. */
Y_print(int nArgs)278 void Y_print(int nArgs)
279 {
280 Operand op;
281 Symbol *stack= sp-nArgs+1;
282 if (CalledAsSubroutine()) {
283 PrintInit(YputsOut);
284 PushDataBlock(RefNC(&nilDB));
285 } else {
286 PrintInit(&PutsAsArray);
287 PushDataBlock(NewArray(&stringStruct, (Dimension *)0));
288 }
289 while (nArgs--) {
290 if (!stack->ops) YError("print accepts no keywords (do you mean write?)");
291 stack->ops->FormOperand(stack, &op);
292 op.ops->Print(&op);
293 if (nArgs) PermitNewline(2);
294 stack++;
295 }
296 ForceNewline();
297 }
298
299 /* PutsAsArray appends string to string array on top of stack --
300 intended as a plug-in replacement for YputsOut */
PutsAsArray(char * s)301 int PutsAsArray(char *s)
302 {
303 Array *array= (Array *)sp->value.db;
304 Dimension *dims= array->type.dims;
305 long number;
306 if (dims) {
307 number= dims->number;
308 sp->value.db= (DataBlock *)GrowArray(array, 1L);
309 Unref(array);
310 array= (Array *)sp->value.db;
311 } else {
312 array->type.dims= NewDimension(1L, 1L, (Dimension *)0);
313 number= 0;
314 }
315 array->value.q[number]= p_strcpy(s);
316 return 0;
317 }
318
319 static char *printBuf= 0;
320 static int lenPrintBuf= 0;
321 static int printNow, permitNow;
322 static long printLines;
323
PrintInit(int (* puts_fun)(char *))324 void PrintInit(int (*puts_fun)(char *))
325 {
326 RawPrinter= puts_fun;
327 if (lenPrintBuf<printLength || (printLength<=79 && lenPrintBuf>79)) {
328 char *p= printBuf;
329 printBuf= 0;
330 p_free(p);
331 if (printLength<39) printLength= 39;
332 else if (printLength>256) printLength= 256;
333 printBuf= p_malloc(printLength+2); /* allow for newline, \0 */
334 lenPrintBuf= printLength;
335 }
336 printNow= permitNow= 0;
337 printLines= 0;
338 printBuf[0]= '\0';
339 }
340
PrintFunc(const char * s)341 void PrintFunc(const char *s)
342 {
343 long len= strlen(s);
344 while (printNow+len > printLength) {
345 if (p_signalling) p_abort();
346 if (permitNow) {
347 char savec[2];
348 int i= permitNow, j= 1;
349 savec[0]= printBuf[i];
350 printBuf[i++]= '\0';
351 if (printLines++ < maxPrintLines) RawPrinter(printBuf);
352 printBuf[0]= savec[0];
353 while (i<=printNow) printBuf[j++]= printBuf[i++];
354 printNow-= permitNow;
355 permitNow= 0;
356 } else {
357 long nhere= printLength-printNow-1;
358 char movec= '\0';
359 if (nhere>0) {
360 strncpy(&printBuf[printNow], s, nhere);
361 s+= nhere;
362 len-= nhere;
363 } else if (nhere<0) { /* only -1 is possible */
364 movec= printBuf[printLength-1];
365 }
366 strcpy(&printBuf[printLength-1], "\\");
367 if (printLines++ < maxPrintLines) RawPrinter(printBuf);
368 if (nhere >= 0) {
369 printNow= 0;
370 printBuf[0]= '\0';
371 } else {
372 printNow= 1;
373 printBuf[0]= movec;
374 printBuf[1]= '\0';
375 }
376 }
377 }
378 strcpy(&printBuf[printNow], s);
379 printNow+= len;
380 }
381
PermitNewline(int nSpaces)382 void PermitNewline(int nSpaces)
383 {
384 if (printNow+nSpaces > printLength) ForceNewline();
385 else while (nSpaces--) printBuf[printNow++]= ' ';
386 printBuf[printNow]= '\0';
387 permitNow= printNow;
388 }
389
ForceNewline(void)390 void ForceNewline(void)
391 {
392 if (p_signalling) p_abort();
393 if (printNow) {
394 if (printLines++ < maxPrintLines) RawPrinter(printBuf);
395 printNow= permitNow= 0;
396 printBuf[0]= '\0';
397 }
398 }
399
PrintFN(Operand * op)400 void PrintFN(Operand *op)
401 {
402 Function *f= op->value;
403 Instruction *pc= f->code;
404 long posList;
405 int n;
406
407 PrintFunc("func ");
408 if (pc->index < 0) PrintFunc("<nameless>");
409 else PrintFunc(globalTable.names[pc->index]);
410 pc++;
411
412 PrintFunc("(");
413 PermitNewline(0);
414 n= f->nPos;
415 posList= f->hasPosList;
416 while (n--) {
417 posList>>= 1;
418 if (posList&1) PrintFunc("&");
419 PrintFunc(globalTable.names[(pc++)->index]);
420 if (n || (f->hasPosList&1) || f->nKey)
421 { PrintFunc(","); PermitNewline(0); }
422 }
423 n= f->nKey;
424 if (f->hasPosList&1) {
425 pc++; /* skip *va* parameter */
426 PrintFunc("..");
427 if (n) { PrintFunc(","); PermitNewline(0); }
428 }
429 while (n--) {
430 PrintFunc(globalTable.names[(pc++)->index]);
431 if (n) { PrintFunc("=,"); PermitNewline(0); }
432 else PrintFunc("=");
433 }
434 PrintFunc(")");
435 }
436
PrintBI(Operand * op)437 void PrintBI(Operand *op)
438 {
439 BIFunction *bif= op->value;
440 char *name;
441 long len;
442 name= bif->index>=0? globalTable.names[bif->index] : "<nameless>";
443 len= strlen(name);
444 strcpy(nBuffer, "builtin ");
445 strncat(nBuffer+8, name, 64);
446 if (len>64) strcpy(nBuffer+72, "...");
447 strcat(nBuffer, "()");
448 PrintFunc(nBuffer);
449 }
450
PrintX(Operand * op)451 void PrintX(Operand *op)
452 {
453 DataBlock *db= op->value;
454 char *name= db? db->ops->typeName : "<unknown>";
455 long len;
456 len= strlen(name);
457 strcpy(nBuffer, "Object of type: ");
458 strncat(nBuffer+16, name, 64);
459 if (len>56) strcpy(nBuffer+72, "...");
460 PrintFunc(nBuffer);
461 }
462
PrintArray(Operand * at)463 static void PrintArray(Operand *at)
464 {
465 Dimension *dims= at->type.dims;
466 if (!dims) {
467 PrintRaw(at);
468 } else {
469 void (*OrigPrintRaw)(Operand *)= PrintRaw;
470 long n= dims->number;
471 at->type.dims= dims->next;
472 PrintFunc("[");
473 for (;;) {
474 PrintArray(at);
475 PrintRaw= OrigPrintRaw; /* PrintRawSI changes this */
476 if (!(--n)) break;
477 PrintFunc(",");
478 PermitNewline(0);
479 }
480 PrintFunc("]");
481 at->type.dims= dims;
482 }
483 }
484
PrintC(Operand * op)485 void PrintC(Operand *op) { PrintRaw= PrintRawC; PrintArray(op); }
PrintS(Operand * op)486 void PrintS(Operand *op) { PrintRaw= PrintRawS; PrintArray(op); }
PrintI(Operand * op)487 void PrintI(Operand *op) { PrintRaw= PrintRawI; PrintArray(op); }
PrintL(Operand * op)488 void PrintL(Operand *op) { PrintRaw= PrintRawL; PrintArray(op); }
PrintF(Operand * op)489 void PrintF(Operand *op) { PrintRaw= PrintRawF; PrintArray(op); }
PrintD(Operand * op)490 void PrintD(Operand *op) { PrintRaw= PrintRawD; PrintArray(op); }
PrintZ(Operand * op)491 void PrintZ(Operand *op) { PrintRaw= PrintRawZ; PrintArray(op); }
PrintQ(Operand * op)492 void PrintQ(Operand *op) { PrintRaw= PrintRawQ; PrintArray(op); }
PrintP(Operand * op)493 void PrintP(Operand *op) { PrintRaw= PrintRawP; PrintArray(op); }
PrintSI(Operand * op)494 void PrintSI(Operand *op) { PrintRaw= PrintRawSI; PrintArray(op); }
495
496 #define DEFAULT_CHAR "0x%02x"
497 #define DEFAULT_SHORT "%d"
498 #define DEFAULT_INT "%d"
499 #define DEFAULT_LONG "%ld"
500 #define DEFAULT_FLOAT "%g"
501 #define DEFAULT_DOUBLE "%g"
502 #define DEFAULT_COMPLEX "%g%+gi"
503 #define DEFAULT_POINTER "%p"
504
505 static char *typeDefault[8]= {
506 DEFAULT_CHAR, DEFAULT_SHORT, DEFAULT_INT, DEFAULT_LONG,
507 DEFAULT_FLOAT, DEFAULT_DOUBLE, DEFAULT_COMPLEX, DEFAULT_POINTER };
508
DefaultPrintFormat(int type)509 void DefaultPrintFormat(int type)
510 {
511 if (type & (1<<T_CHAR)) yCharFormat= typeDefault[0];
512 if (type & (1<<T_SHORT)) yShortFormat= typeDefault[1];
513 if (type & (1<<T_INT)) yIntFormat= typeDefault[2];
514 if (type & (1<<T_LONG)) yLongFormat= typeDefault[3];
515 if (type & (1<<T_FLOAT)) yFloatFormat= typeDefault[4];
516 if (type & (1<<T_DOUBLE)) yDoubleFormat= typeDefault[5];
517 if (type & (1<<T_COMPLEX)) yComplexFormat= typeDefault[6];
518 if (type & (1<<T_POINTER)) yPointerFormat= typeDefault[7];
519 }
520
521 char *yCharFormat= DEFAULT_CHAR;
PrintRawC(Operand * at)522 static void PrintRawC(Operand *at)
523 { unsigned char *pv= at->value; sprintf(nBuffer, yCharFormat, (int)*pv);
524 PrintFunc(nBuffer); at->value= pv+1; }
525
526 char *yShortFormat= DEFAULT_SHORT;
PrintRawS(Operand * at)527 static void PrintRawS(Operand *at)
528 { short *pv= at->value; sprintf(nBuffer, yShortFormat, (int)*pv);
529 PrintFunc(nBuffer); at->value= pv+1; }
530
531 char *yIntFormat= DEFAULT_INT;
PrintRawI(Operand * at)532 static void PrintRawI(Operand *at)
533 { int *pv= at->value; sprintf(nBuffer, yIntFormat, *pv);
534 PrintFunc(nBuffer); at->value= pv+1; }
535
536 char *yLongFormat= DEFAULT_LONG;
PrintRawL(Operand * at)537 static void PrintRawL(Operand *at)
538 { long *pv= at->value; sprintf(nBuffer, yLongFormat, *pv);
539 PrintFunc(nBuffer); at->value= pv+1; }
540
541 char *yFloatFormat= DEFAULT_FLOAT;
PrintRawF(Operand * at)542 static void PrintRawF(Operand *at)
543 { float *pv= at->value; sprintf(nBuffer, yFloatFormat, (double)*pv);
544 PrintFunc(nBuffer); at->value= pv+1; }
545
546 char *yDoubleFormat= DEFAULT_DOUBLE;
PrintRawD(Operand * at)547 static void PrintRawD(Operand *at)
548 { double *pv= at->value; sprintf(nBuffer, yDoubleFormat, *pv);
549 PrintFunc(nBuffer); at->value= pv+1; }
550
551 char *yComplexFormat= DEFAULT_COMPLEX;
PrintRawZ(Operand * at)552 static void PrintRawZ(Operand *at)
553 { double *pv= at->value; sprintf(nBuffer, yComplexFormat, pv[0], pv[1]);
554 PrintFunc(nBuffer); at->value= pv+2; }
555
556 char *yPointerFormat= DEFAULT_POINTER;
PrintRawP(Operand * at)557 static void PrintRawP(Operand *at)
558 { void **pv= at->value; sprintf(nBuffer, yPointerFormat, *pv);
559 PrintFunc(nBuffer); at->value= pv+1; }
560
561 static long typeIndex[8]= { -1, -1, -1, -1, -1, -1, -1, -1 };
562 static char **typeFormat[8]= {
563 &yCharFormat, &yShortFormat, &yIntFormat, &yLongFormat,
564 &yFloatFormat, &yDoubleFormat, &yComplexFormat, &yPointerFormat };
565
Y_print_format(int nArgs)566 void Y_print_format(int nArgs)
567 {
568 Symbol *arg = sp-nArgs+1;
569 int npos = 0;
570
571 if (typeIndex[0]<0) {
572 typeIndex[0]= Globalize("char", 0L);
573 typeIndex[1]= Globalize("short", 0L);
574 typeIndex[2]= Globalize("int", 0L);
575 typeIndex[3]= Globalize("long", 0L);
576 typeIndex[4]= Globalize("float", 0L);
577 typeIndex[5]= Globalize("double", 0L);
578 typeIndex[6]= Globalize("complex", 0L);
579 typeIndex[7]= Globalize("pointer", 0L);
580 }
581
582 if (nArgs < 1) {
583 DefaultPrintFormat(~0);
584 printLength= 79;
585 maxPrintLines= 5000;
586 } else do {
587 if (arg->ops) {
588 if (++npos > 2) YError("print_format expects at most two positional arguments");
589 if (YNotNil(arg)) {
590 long i = YGetInteger(arg);
591 if (npos == 1) {
592 if (i>256) printLength = 256;
593 else if (i>39) printLength = i;
594 else if (i>0) printLength = 39;
595 else printLength = 79;
596 } else {
597 if (i < 10) maxPrintLines = (i<=0)? 5000 : 10;
598 else maxPrintLines = i;
599 }
600 }
601 arg++;
602 } else {
603 long index= (arg++)->index;
604 int i;
605 char *string;
606 for (i=0 ; i<8 ; i++) if (typeIndex[i]==index) break;
607 if (i>=8) YError("unrecognized keyword in print_format");
608 string= *typeFormat[i];
609 *typeFormat[i]= typeDefault[i];
610 if (string!=typeDefault[i]) p_free(string);
611 string= YGetString(arg++);
612 nArgs--;
613 if (string && strlen(string)) *typeFormat[i]= p_strcpy(string);
614 }
615 } while (--nArgs);
616 }
617
618 static char *sPart= 0;
619 static long sPartLen= 0;
620
GetTempBuffer(long len)621 static char *GetTempBuffer(long len)
622 {
623 if (len>=sPartLen) {
624 long newlen= ((len-1)/80 + 1)*80;
625 ClearTempBuffer(1);
626 sPart= p_malloc(newlen+1);
627 sPartLen= newlen;
628 }
629 return sPart;
630 }
631
ClearTempBuffer(int force)632 static void ClearTempBuffer(int force)
633 {
634 if (force || sPartLen>80) {
635 char *part= sPart;
636 sPartLen= 0;
637 sPart= 0;
638 p_free(part);
639 }
640 }
641
ScanForEscape(char * s)642 char *ScanForEscape(char *s)
643 {
644 char c;
645 if (!s) return 0;
646 while ((c= *s) && c>=' ' && c<'\177' && c!='\\' && c!='\"') s++;
647 return s;
648 }
649
AddEscapeSeq(char * s,int esc)650 int AddEscapeSeq(char *s, int esc)
651 {
652 int n= 2;
653 if (esc=='\\') strcpy(s, "\\\\");
654 else if (esc=='\"') strcpy(s, "\\\"");
655 else if (esc=='\n') strcpy(s, "\\n");
656 else if (esc=='\t') strcpy(s, "\\t");
657 else if (esc=='\a') strcpy(s, "\\a");
658 else if (esc=='\f') strcpy(s, "\\f");
659 else if (esc=='\r') strcpy(s, "\\r");
660 else if (esc=='\v') strcpy(s, "\\v");
661 else if (esc=='\b') strcpy(s, "\\b");
662 else { sprintf(s, "\\%03o", esc&0xff); n= 4; }
663 return n;
664 }
665
PrintRawQ(Operand * at)666 static void PrintRawQ(Operand *at)
667 {
668 char **pv= at->value;
669 char *s= *pv++;
670 char *esc;
671 if (!s) {
672 PrintRawP(at);
673 } else {
674 PrintFunc("\"");
675 if (*(esc= ScanForEscape(s))) {
676 char *part;
677 do {
678 part= GetTempBuffer(esc-s + 4);
679 strncpy(part, s, esc-s);
680 AddEscapeSeq(part + (esc-s), (int)(*esc));
681 PrintFunc(part);
682 s= esc+1;
683 } while (*(esc= ScanForEscape(s)));
684 ClearTempBuffer(0);
685 }
686 if (*s) PrintFunc(s);
687 PrintFunc("\"");
688 }
689 at->value= pv;
690 }
691
PrintRawSI(Operand * at)692 static void PrintRawSI(Operand *at)
693 {
694 char *pv= at->value;
695 StructDef *base= at->type.base;
696 Operand subOp;
697 long n= base->table.nItems;
698 char **name= base->table.names;
699 Member *member= base->members;
700 long *offset= base->offsets;
701
702 if (base->file) YError("(BUG?) can't print an instance of a disk struct");
703
704 PrintFunc(StructName(base));
705 PrintFunc("(");
706 PermitNewline(0);
707 for (;;) {
708 PrintFunc(*name);
709 PrintFunc("=");
710 PermitNewline(0);
711 subOp.type.base= member->base;
712 subOp.type.dims= member->dims;
713 subOp.value= pv + (*offset);
714 subOp.type.base->dataOps->Print(&subOp);
715 if (!(--n)) break;
716 PrintFunc(",");
717 PermitNewline(0);
718 name++;
719 member++;
720 offset++;
721 }
722 PrintFunc(")");
723
724 at->value= pv + base->size;
725 }
726
727 /* range functions */
728 extern RangeFunc RFmin, RFmax, RFptp, RFsum, RFavg, RFrms, RFmnx, RFmxx,
729 RFpsum, RFdif, RFzcen, RFpcen, RFuncp, RFcum;
730
731 static char *rfNames[]= { "avg:","cum:","dif:","max:","min:","mnx:","mxx:",
732 "pcen:","psum:","ptp:","rms:","sum:","uncp:","zcen:","??:" };
733
734 static RangeFunc *RFs[]= { &RFavg,&RFcum,&RFdif,&RFmax,&RFmin,&RFmnx,&RFmxx,
735 &RFpcen,&RFpsum,&RFptp,&RFrms,&RFsum,&RFuncp,&RFzcen,0 };
736
737 static int rfindex[] = { 9,18,14,6,5,11,12,16,13,7,10,8,17,15, 19 };
738 static int rfxedni[] = { 4, 3, 9, 11, 0, 10, 5, 6, 8, 2, 13, 7, 12, 1, -1 };
739
GetRFName(RangeFunc * rfTarget)740 char *GetRFName(RangeFunc *rfTarget)
741 {
742 RangeFunc **rf= RFs;
743 while (*rf && *rf!=rfTarget) rf++;
744 return rfNames[rf-RFs];
745 }
746
747 void
Y_rangeof(int argc)748 Y_rangeof(int argc)
749 {
750 Range *rng;
751 Dimension *dims;
752 long *nrng;
753 if (sp->ops==&referenceSym) ReplaceRef(sp);
754 rng = (sp->ops==&dataBlockSym
755 && sp->value.db->ops==&rangeOps)? (Range *)sp->value.db : 0;
756 nrng = rng? 0 : YGet_L(sp, 0, &dims);
757 if (argc!=1 || (!rng && (!nrng || !dims || dims->number!=4 || dims->next)))
758 YError("rangeof expecting index range or array of 4 longs");
759 if (rng) { /* convert rf:min:max:step to [flag, min, max, step] */
760 int i = 0, j = 0, k = 0;
761 if (rng->rf) {
762 for (i=0 ; i<14 ; i++) if (RFs[i] == rng->rf) break;
763 i = rfindex[i];
764 }
765 if (rng->nilFlags & R_PSEUDO) j = (rng->nilFlags & R_RUBBER)? 3 : 1;
766 else if (rng->nilFlags & R_RUBBER) j = 2;
767 else if (rng->nilFlags & R_NULLER) j = 4;
768 k = ((rng->nilFlags & R_MINNIL)!=0) | (((rng->nilFlags & R_MAXNIL)!=0)<<1);
769 dims = tmpDims; tmpDims = 0; FreeDimension(dims);
770 tmpDims = NewDimension(4L, 1L, 0);
771 nrng = ((Array*)PushDataBlock(NewArray(&longStruct, tmpDims)))->value.l;
772 nrng[0] = rng->min;
773 nrng[1] = rng->max;
774 nrng[2] = rng->inc;
775 nrng[3] = k | ((j + ((!j)? i : 0))<<2);
776 } else { /* convert [flag, min, max, step] to rf:min:max:step */
777 long inc = nrng[2]? nrng[2] : 1;
778 int flags = ((nrng[3]&1)? R_MINNIL : 0) | ((nrng[3]&2)? R_MAXNIL : 0);
779 long f = (nrng[3] >> 2);
780 if (f == 1) flags |= R_PSEUDO;
781 else if (f == 2) flags |= R_RUBBER;
782 else if (f == 3) flags |= R_RUBBER | R_PSEUDO;
783 else if (f == 4) flags |= R_NULLER;
784 rng = PushDataBlock(NewRange(nrng[0], nrng[1], inc, flags));
785 if (f > 4) {
786 f = rfxedni[((f<20)?f:19)-5];
787 if (f < 0) { /* make illegal range */
788 rng->min = 2; rng->max = 1; rng->inc = 1; rng->nilFlags = 0;
789 f = 0;
790 } else {
791 rng->rf = RFs[f];
792 }
793 }
794 }
795 }
796
PrintR(Operand * op)797 void PrintR(Operand *op)
798 {
799 Range *range= op->value;
800 int flags= range->nilFlags;
801 long len;
802 if (range->rf) {
803 strcpy(nBuffer, GetRFName(range->rf));
804 len= strlen(nBuffer);
805 } else if (flags&R_MARKED) {
806 strcpy(nBuffer, "+:");
807 len= 2;
808 } else if (flags&R_PSEUDO) {
809 strcpy(nBuffer, "-:");
810 len= 2;
811 } else if (flags&R_RUBBER) {
812 PrintFunc("<..>:");
813 return;
814 } else if (flags&R_NULLER) {
815 PrintFunc("<nuller>:");
816 return;
817 } else {
818 nBuffer[0]= '\0';
819 len= 0;
820 }
821 if (flags&R_MINNIL) {
822 if (flags&R_MAXNIL) {
823 strcpy(nBuffer+len, ":");
824 } else {
825 sprintf(nBuffer+len, ":%ld", range->max);
826 }
827 } else if (flags&R_MAXNIL) {
828 sprintf(nBuffer+len, "%ld:", range->min);
829 } else {
830 sprintf(nBuffer+len, "%ld:%ld", range->min, range->max);
831 }
832 if (range->inc!=1) {
833 len= strlen(nBuffer);
834 sprintf(nBuffer+len, ":%ld", range->inc);
835 }
836 PrintFunc(nBuffer);
837 }
838
839 /* ARGSUSED */
PrintVD(Operand * op)840 void PrintVD(Operand *op)
841 {
842 PrintFunc("[]");
843 }
844
PDRecurse(Dimension * dims,long * length,int last)845 static int PDRecurse(Dimension *dims, long *length, int last)
846 {
847 long len;
848 int count;
849
850 if (!dims) return 0;
851 count= PDRecurse(dims->next, length, 0);
852 if (count<0) return count-1;
853 len= *length;
854
855 if (dims->origin!=1L) {
856 if (len>45) return -1;
857 sprintf(nBuffer+len, "%ld:%ld",
858 dims->origin, dims->origin+dims->number-1);
859 } else {
860 if (len>60) return -1;
861 sprintf(nBuffer+len, "%ld", dims->number);
862 }
863 len+= strlen(nBuffer+len);
864 if (!last) { strcpy(nBuffer+len, ","); len++; }
865
866 *length= len;
867 return count+1;
868 }
869
PrintDims(Dimension * dims)870 static void PrintDims(Dimension *dims)
871 {
872 if (dims) {
873 long len= 1;
874 strcpy(nBuffer, "(");
875 if (PDRecurse(dims, &len, 1)<0) {
876 strcpy(nBuffer+len, "...");
877 len+= 3;
878 }
879 strcpy(nBuffer+len, ")");
880 PrintFunc(nBuffer);
881 }
882 }
883
PrintSD(Operand * at)884 void PrintSD(Operand *at)
885 {
886 StructDef *base= at->value;
887 long n= base->table.nItems;
888 Member *member= base->members;
889 char **name= base->table.names;
890
891 ForceNewline();
892 PrintFunc("struct ");
893 PrintFunc(StructName(base));
894 PrintFunc(" {");
895 ForceNewline();
896 while (n--) {
897 PrintFunc(" ");
898 PrintFunc(StructName(member->base));
899 PrintFunc(" ");
900 PrintFunc(*name);
901 PrintDims(member->dims);
902 PrintFunc(";");
903 ForceNewline();
904 member++;
905 name++;
906 }
907 PrintFunc("}");
908 ForceNewline();
909 }
910
911 /*--------------------------------------------------------------------------*/
912
913 static char *printText= 0, *tmpText= 0;
914 static char *ioStatus[]=
915 { "<illegal>", "read-only", "write-only", "read-write" };
916
917 static void SafeFree(char **s);
SafeFree(char ** s)918 static void SafeFree(char **s)
919 {
920 char *t= *s;
921 *s= 0;
922 p_free(t);
923 }
924
PrintIO(Operand * op)925 void PrintIO(Operand *op)
926 {
927 IOStream *file= op->value;
928 char text[80];
929 SafeFree(&printText);
930 SafeFree(&tmpText);
931
932 /* read-write binary stream: <tail of fullname>
933 In directory: <head of fullname>
934 Current record is number 53 of 53
935 File of current record: <tail of child's name>
936 Time, cycle of current record: 1.234567e+00, 9876
937 */
938
939 ForceNewline();
940 if (file->stream) {
941 sprintf(text, "%s binary stream: ", ioStatus[file->permissions&3]);
942 tmpText= YNameTail(file->fullname);
943 } else {
944 strcpy(text, "binary stream <closed>: ");
945 }
946 printText= p_strncat(text, tmpText, 0);
947 SafeFree(&tmpText);
948 PrintFunc(printText);
949 SafeFree(&printText);
950 ForceNewline();
951
952 tmpText= YNameHead(file->fullname);
953 printText= p_strncat(" In directory: ", tmpText, 0);
954 SafeFree(&tmpText);
955 PrintFunc(printText);
956 SafeFree(&printText);
957 ForceNewline();
958
959 if (file->history) {
960 HistoryInfo *history= file->history;
961
962 if (history->recNumber>=0) {
963 long i= history->recNumber;
964
965 sprintf(text, " Current record is number %ld of %ld",
966 i+1, history->nRecords);
967 PrintFunc(text);
968 ForceNewline();
969
970 tmpText= YNameTail(history->child->fullname);
971 printText= p_strncat(" File of current record: ", tmpText, 0);
972 SafeFree(&tmpText);
973 PrintFunc(printText);
974 SafeFree(&printText);
975 ForceNewline();
976
977 if (history->time) {
978 if (history->ncyc) {
979 sprintf(text, " Time, cycle of current record: %.6e, %ld",
980 history->time[i], history->ncyc[i]);
981 } else {
982 sprintf(text, " Time of current record: %.6e",
983 history->time[i]);
984 }
985 } else {
986 if (history->ncyc) {
987 sprintf(text, " Cycle of current record: %ld",
988 history->ncyc[i]);
989 } else {
990 strcpy(text, " <No time or cycle available>");
991 }
992 }
993 PrintFunc(text);
994 ForceNewline();
995
996 } else {
997 PrintFunc(" <No current record>");
998 ForceNewline();
999 }
1000 }
1001 }
1002
1003 /*--------------------------------------------------------------------------*/
1004
1005 /* Set up a block allocator which grabs space for 16 IOFileLink objects
1006 at a time. Since IOFileLink contains several pointers, the alignment
1007 of an IOFileLink must be at least as strict as a void*. */
1008 static MemryBlock ioflBlock= {0, 0, sizeof(IOFileLink),
1009 16*sizeof(IOFileLink)};
1010
AddIOLink(IOFileLink ** list,void * ios)1011 void AddIOLink(IOFileLink** list, void *ios)
1012 {
1013 IOFileLink *first= *list;
1014 IOFileLink *iofl= NextUnit(&ioflBlock);
1015 iofl->next= first;
1016 iofl->prev= list;
1017 iofl->ios= ios;
1018 *list= iofl;
1019 if (first) first->prev= &iofl->next;
1020 }
1021
RemoveIOLink(IOFileLink * iofl,void * ios)1022 void RemoveIOLink(IOFileLink* iofl, void *ios)
1023 {
1024 for ( ; iofl ; iofl=iofl->next) if (iofl->ios==ios) break;
1025 if (iofl) {
1026 *iofl->prev= iofl->next;
1027 if (iofl->next) iofl->next->prev= iofl->prev;
1028 FreeUnit(&ioflBlock, iofl);
1029 }
1030 }
1031
1032 /*--------------------------------------------------------------------------*/
1033
YpReparse(void * function)1034 char *YpReparse(void *function)
1035 {
1036 Function *func= function;
1037 long index= func? func->code[0].index : -1;
1038 long position= ReopenSource(index, 1, (func?func->isrc:-1));
1039 char *msg;
1040 if (position>=0) {
1041 YpParse(func); /* This had better not generate any new tasks... */
1042 msg= MakeErrorLine(ypBeginLine,
1043 nYpIncludes? ypIncludes[nYpIncludes-1].filename : 0);
1044 if (nYpIncludes && ypIncludes[nYpIncludes-1].file) {
1045 p_fclose(ypIncludes[nYpIncludes-1].file);
1046 ypIncludes[nYpIncludes-1].file= 0;
1047 }
1048 } else if (position<-3) {
1049 msg= MakeErrorLine(-4,
1050 "*****fseek failed scanning source file for function");
1051 } else if (position<-2) {
1052 msg= MakeErrorLine(-3,
1053 "*****source file changed, no longer contains function");
1054 } else if (position<-1) {
1055 msg= MakeErrorLine(-2,
1056 "*****source file for function no longer exists");
1057 } else {
1058 msg= MakeErrorLine(-1,
1059 "*****source file for function unknown");
1060 }
1061 return msg;
1062 }
1063
1064 /*--------------------------------------------------------------------------*/
1065