1 /*******************************************************/
2 /* "C" Language Integrated Production System */
3 /* */
4 /* CLIPS Version 6.30 01/26/15 */
5 /* */
6 /* I/O FUNCTIONS MODULE */
7 /*******************************************************/
8
9 /*************************************************************/
10 /* Purpose: Contains the code for several I/O functions */
11 /* including printout, read, open, close, remove, rename, */
12 /* format, and readline. */
13 /* */
14 /* Principal Programmer(s): */
15 /* Brian L. Dantes */
16 /* Gary D. Riley */
17 /* Bebe Ly */
18 /* */
19 /* Contributing Programmer(s): */
20 /* */
21 /* Revision History: */
22 /* */
23 /* 6.24: Added the get-char, set-locale, and */
24 /* read-number functions. */
25 /* */
26 /* Modified printing of floats in the format */
27 /* function to use the locale from the set-locale */
28 /* function. */
29 /* */
30 /* Moved IllegalLogicalNameMessage function to */
31 /* argacces.c. */
32 /* */
33 /* 6.30: Changed integer type/precision. */
34 /* */
35 /* Support for long long integers. */
36 /* */
37 /* Removed the undocumented use of t in the */
38 /* printout command to perform the same function */
39 /* as crlf. */
40 /* */
41 /* Replaced EXT_IO and BASIC_IO compiler flags */
42 /* with IO_FUNCTIONS compiler flag. */
43 /* */
44 /* Added rb and ab and removed r+ modes for the */
45 /* open function. */
46 /* */
47 /* Removed conditional code for unsupported */
48 /* compilers/operating systems (IBM_MCW and */
49 /* MAC_MCW). */
50 /* */
51 /* Used gensprintf instead of sprintf. */
52 /* */
53 /* Added put-char function. */
54 /* */
55 /* Added SetFullCRLF which allows option to */
56 /* specify crlf as \n or \r\n. */
57 /* */
58 /* Added AwaitingInput flag. */
59 /* */
60 /* Added const qualifiers to remove C++ */
61 /* deprecation warnings. */
62 /* */
63 /* Added STDOUT and STDIN logical name */
64 /* definitions. */
65 /* */
66 /*************************************************************/
67
68 #define _IOFUN_SOURCE_
69
70 #include "setup.h"
71
72 #if IO_FUNCTIONS
73 #include <locale.h>
74 #include <stdlib.h>
75 #include <ctype.h>
76 #endif
77
78 #include <stdio.h>
79 #define _STDIO_INCLUDED_
80 #include <string.h>
81
82 #include "envrnmnt.h"
83 #include "router.h"
84 #include "strngrtr.h"
85 #include "filertr.h"
86 #include "argacces.h"
87 #include "extnfunc.h"
88 #include "scanner.h"
89 #include "constant.h"
90 #include "memalloc.h"
91 #include "commline.h"
92 #include "sysdep.h"
93 #include "utility.h"
94
95 #include "iofun.h"
96
97 /***************/
98 /* DEFINITIONS */
99 /***************/
100
101 #define FORMAT_MAX 512
102 #define FLAG_MAX 80
103
104 /********************/
105 /* ENVIRONMENT DATA */
106 /********************/
107
108 #define IO_FUNCTION_DATA 64
109
110 struct IOFunctionData
111 {
112 void *locale;
113 intBool useFullCRLF;
114 };
115
116 #define IOFunctionData(theEnv) ((struct IOFunctionData *) GetEnvironmentData(theEnv,IO_FUNCTION_DATA))
117
118 /****************************************/
119 /* LOCAL INTERNAL FUNCTION DEFINITIONS */
120 /****************************************/
121
122 #if IO_FUNCTIONS
123 static void ReadTokenFromStdin(void *,struct token *);
124 static const char *ControlStringCheck(void *,int);
125 static char FindFormatFlag(const char *,size_t *,char *,size_t);
126 static const char *PrintFormatFlag(void *,const char *,int,int);
127 static char *FillBuffer(void *,const char *,size_t *,size_t *);
128 static void ReadNumber(void *,const char *,struct token *,int);
129 #endif
130
131 /**************************************/
132 /* IOFunctionDefinitions: Initializes */
133 /* the I/O functions. */
134 /**************************************/
IOFunctionDefinitions(void * theEnv)135 globle void IOFunctionDefinitions(
136 void *theEnv)
137 {
138 AllocateEnvironmentData(theEnv,IO_FUNCTION_DATA,sizeof(struct IOFunctionData),NULL);
139
140 #if IO_FUNCTIONS
141 IOFunctionData(theEnv)->useFullCRLF = FALSE;
142 IOFunctionData(theEnv)->locale = (SYMBOL_HN *) EnvAddSymbol(theEnv,setlocale(LC_ALL,NULL));
143 IncrementSymbolCount(IOFunctionData(theEnv)->locale);
144 #endif
145
146 #if ! RUN_TIME
147 #if IO_FUNCTIONS
148 EnvDefineFunction2(theEnv,"printout", 'v', PTIEF PrintoutFunction, "PrintoutFunction", "1*");
149 EnvDefineFunction2(theEnv,"read", 'u', PTIEF ReadFunction, "ReadFunction", "*1");
150 EnvDefineFunction2(theEnv,"open", 'b', OpenFunction, "OpenFunction", "23*k");
151 EnvDefineFunction2(theEnv,"close", 'b', CloseFunction, "CloseFunction", "*1");
152 EnvDefineFunction2(theEnv,"get-char", 'i', GetCharFunction, "GetCharFunction", "*1");
153 EnvDefineFunction2(theEnv,"put-char", 'v', PTIEF PutCharFunction, "PutCharFunction", "12");
154 EnvDefineFunction2(theEnv,"remove", 'b', RemoveFunction, "RemoveFunction", "11k");
155 EnvDefineFunction2(theEnv,"rename", 'b', RenameFunction, "RenameFunction", "22k");
156 EnvDefineFunction2(theEnv,"format", 's', PTIEF FormatFunction, "FormatFunction", "2**us");
157 EnvDefineFunction2(theEnv,"readline", 'k', PTIEF ReadlineFunction, "ReadlineFunction", "*1");
158 EnvDefineFunction2(theEnv,"set-locale", 'u', PTIEF SetLocaleFunction, "SetLocaleFunction", "*1");
159 EnvDefineFunction2(theEnv,"read-number", 'u', PTIEF ReadNumberFunction, "ReadNumberFunction", "*1");
160 #endif
161 #else
162 #if MAC_XCD
163 #pragma unused(theEnv)
164 #endif
165 #endif
166 }
167
168 #if IO_FUNCTIONS
169
170 /******************************************/
171 /* PrintoutFunction: H/L access routine */
172 /* for the printout function. */
173 /******************************************/
PrintoutFunction(void * theEnv)174 globle void PrintoutFunction(
175 void *theEnv)
176 {
177 const char *dummyid;
178 int i, argCount;
179 DATA_OBJECT theArgument;
180
181 /*=======================================================*/
182 /* The printout function requires at least one argument. */
183 /*=======================================================*/
184
185 if ((argCount = EnvArgCountCheck(theEnv,"printout",AT_LEAST,1)) == -1) return;
186
187 /*=====================================================*/
188 /* Get the logical name to which output is to be sent. */
189 /*=====================================================*/
190
191 dummyid = GetLogicalName(theEnv,1,STDOUT);
192 if (dummyid == NULL)
193 {
194 IllegalLogicalNameMessage(theEnv,"printout");
195 SetHaltExecution(theEnv,TRUE);
196 SetEvaluationError(theEnv,TRUE);
197 return;
198 }
199
200 /*============================================================*/
201 /* Determine if any router recognizes the output destination. */
202 /*============================================================*/
203
204 if (strcmp(dummyid,"nil") == 0)
205 { return; }
206 else if (QueryRouters(theEnv,dummyid) == FALSE)
207 {
208 UnrecognizedRouterMessage(theEnv,dummyid);
209 return;
210 }
211
212 /*===============================================*/
213 /* Print each of the arguments sent to printout. */
214 /*===============================================*/
215
216 for (i = 2; i <= argCount; i++)
217 {
218 EnvRtnUnknown(theEnv,i,&theArgument);
219 if (EvaluationData(theEnv)->HaltExecution) break;
220
221 switch(GetType(theArgument))
222 {
223 case SYMBOL:
224 if (strcmp(DOToString(theArgument),"crlf") == 0)
225 {
226 if (IOFunctionData(theEnv)->useFullCRLF)
227 { EnvPrintRouter(theEnv,dummyid,"\r\n"); }
228 else
229 { EnvPrintRouter(theEnv,dummyid,"\n"); }
230 }
231 else if (strcmp(DOToString(theArgument),"tab") == 0)
232 { EnvPrintRouter(theEnv,dummyid,"\t"); }
233 else if (strcmp(DOToString(theArgument),"vtab") == 0)
234 { EnvPrintRouter(theEnv,dummyid,"\v"); }
235 else if (strcmp(DOToString(theArgument),"ff") == 0)
236 { EnvPrintRouter(theEnv,dummyid,"\f"); }
237 /*
238 else if (strcmp(DOToString(theArgument),"t") == 0)
239 {
240 if (IOFunctionData(theEnv)->useFullCRLF)
241 { EnvPrintRouter(theEnv,dummyid,"\r\n"); }
242 else
243 { EnvPrintRouter(theEnv,dummyid,"\n"); }
244 }
245 */
246 else
247 { EnvPrintRouter(theEnv,dummyid,DOToString(theArgument)); }
248 break;
249
250 case STRING:
251 EnvPrintRouter(theEnv,dummyid,DOToString(theArgument));
252 break;
253
254 default:
255 PrintDataObject(theEnv,dummyid,&theArgument);
256 break;
257 }
258 }
259 }
260
261 /*****************************************************/
262 /* SetFullCRLF: Set the flag which indicates whether */
263 /* crlf is treated just as '\n' or '\r\n'. */
264 /*****************************************************/
SetFullCRLF(void * theEnv,intBool value)265 globle intBool SetFullCRLF(
266 void *theEnv,
267 intBool value)
268 {
269 intBool oldValue = IOFunctionData(theEnv)->useFullCRLF;
270
271 IOFunctionData(theEnv)->useFullCRLF = value;
272
273 return(oldValue);
274 }
275
276 /*************************************************************/
277 /* ReadFunction: H/L access routine for the read function. */
278 /*************************************************************/
ReadFunction(void * theEnv,DATA_OBJECT_PTR returnValue)279 globle void ReadFunction(
280 void *theEnv,
281 DATA_OBJECT_PTR returnValue)
282 {
283 struct token theToken;
284 int numberOfArguments;
285 const char *logicalName = NULL;
286
287 /*===============================================*/
288 /* Check for an appropriate number of arguments. */
289 /*===============================================*/
290
291 if ((numberOfArguments = EnvArgCountCheck(theEnv,"read",NO_MORE_THAN,1)) == -1)
292 {
293 returnValue->type = STRING;
294 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
295 return;
296 }
297
298 /*======================================================*/
299 /* Determine the logical name from which input is read. */
300 /*======================================================*/
301
302 if (numberOfArguments == 0)
303 { logicalName = STDIN; }
304 else if (numberOfArguments == 1)
305 {
306 logicalName = GetLogicalName(theEnv,1,STDIN);
307 if (logicalName == NULL)
308 {
309 IllegalLogicalNameMessage(theEnv,"read");
310 SetHaltExecution(theEnv,TRUE);
311 SetEvaluationError(theEnv,TRUE);
312 returnValue->type = STRING;
313 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
314 return;
315 }
316 }
317
318 /*============================================*/
319 /* Check to see that the logical name exists. */
320 /*============================================*/
321
322 if (QueryRouters(theEnv,logicalName) == FALSE)
323 {
324 UnrecognizedRouterMessage(theEnv,logicalName);
325 SetHaltExecution(theEnv,TRUE);
326 SetEvaluationError(theEnv,TRUE);
327 returnValue->type = STRING;
328 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
329 return;
330 }
331
332 /*=======================================*/
333 /* Collect input into string if the read */
334 /* source is stdin, else just get token. */
335 /*=======================================*/
336
337 if (strcmp(logicalName,STDIN) == 0)
338 { ReadTokenFromStdin(theEnv,&theToken); }
339 else
340 { GetToken(theEnv,logicalName,&theToken); }
341
342 RouterData(theEnv)->CommandBufferInputCount = 0;
343 RouterData(theEnv)->AwaitingInput = FALSE;
344
345 /*====================================================*/
346 /* Copy the token to the return value data structure. */
347 /*====================================================*/
348
349 returnValue->type = theToken.type;
350 if ((theToken.type == FLOAT) || (theToken.type == STRING) ||
351 #if OBJECT_SYSTEM
352 (theToken.type == INSTANCE_NAME) ||
353 #endif
354 (theToken.type == SYMBOL) || (theToken.type == INTEGER))
355 { returnValue->value = theToken.value; }
356 else if (theToken.type == STOP)
357 {
358 returnValue->type = SYMBOL;
359 returnValue->value = (void *) EnvAddSymbol(theEnv,"EOF");
360 }
361 else if (theToken.type == UNKNOWN_VALUE)
362 {
363 returnValue->type = STRING;
364 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
365 }
366 else
367 {
368 returnValue->type = STRING;
369 returnValue->value = (void *) EnvAddSymbol(theEnv,theToken.printForm);
370 }
371
372 return;
373 }
374
375 /********************************************************/
376 /* ReadTokenFromStdin: Special routine used by the read */
377 /* function to read a token from standard input. */
378 /********************************************************/
ReadTokenFromStdin(void * theEnv,struct token * theToken)379 static void ReadTokenFromStdin(
380 void *theEnv,
381 struct token *theToken)
382 {
383 char *inputString;
384 size_t inputStringSize;
385 int inchar;
386
387 /*=============================================*/
388 /* Continue processing until a token is found. */
389 /*=============================================*/
390
391 theToken->type = STOP;
392 while (theToken->type == STOP)
393 {
394 /*===========================================*/
395 /* Initialize the variables used for storing */
396 /* the characters retrieved from stdin. */
397 /*===========================================*/
398
399 inputString = NULL;
400 RouterData(theEnv)->CommandBufferInputCount = 0;
401 RouterData(theEnv)->AwaitingInput = TRUE;
402 inputStringSize = 0;
403 inchar = EnvGetcRouter(theEnv,STDIN);
404
405 /*========================================================*/
406 /* Continue reading characters until a carriage return is */
407 /* entered or the user halts execution (usually with */
408 /* control-c). Waiting for the carriage return prevents */
409 /* the input from being prematurely parsed (such as when */
410 /* a space is entered after a symbol has been typed). */
411 /*========================================================*/
412
413 while ((inchar != '\n') && (inchar != '\r') && (inchar != EOF) &&
414 (! GetHaltExecution(theEnv)))
415 {
416 inputString = ExpandStringWithChar(theEnv,inchar,inputString,&RouterData(theEnv)->CommandBufferInputCount,
417 &inputStringSize,inputStringSize + 80);
418 inchar = EnvGetcRouter(theEnv,STDIN);
419 }
420
421 /*==================================================*/
422 /* Open a string input source using the characters */
423 /* retrieved from stdin and extract the first token */
424 /* contained in the string. */
425 /*==================================================*/
426
427 OpenStringSource(theEnv,"read",inputString,0);
428 GetToken(theEnv,"read",theToken);
429 CloseStringSource(theEnv,"read");
430 if (inputStringSize > 0) rm(theEnv,inputString,inputStringSize);
431
432 /*===========================================*/
433 /* Pressing control-c (or comparable action) */
434 /* aborts the read function. */
435 /*===========================================*/
436
437 if (GetHaltExecution(theEnv))
438 {
439 theToken->type = STRING;
440 theToken->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
441 }
442
443 /*====================================================*/
444 /* Return the EOF symbol if the end of file for stdin */
445 /* has been encountered. This typically won't occur, */
446 /* but is possible (for example by pressing control-d */
447 /* in the UNIX operating system). */
448 /*====================================================*/
449
450 if ((theToken->type == STOP) && (inchar == EOF))
451 {
452 theToken->type = SYMBOL;
453 theToken->value = (void *) EnvAddSymbol(theEnv,"EOF");
454 }
455 }
456 }
457
458 /*************************************************************/
459 /* OpenFunction: H/L access routine for the open function. */
460 /*************************************************************/
OpenFunction(void * theEnv)461 globle int OpenFunction(
462 void *theEnv)
463 {
464 int numberOfArguments;
465 const char *fileName, *logicalName, *accessMode = NULL;
466 DATA_OBJECT theArgument;
467
468 /*========================================*/
469 /* Check for a valid number of arguments. */
470 /*========================================*/
471
472 if ((numberOfArguments = EnvArgRangeCheck(theEnv,"open",2,3)) == -1) return(0);
473
474 /*====================*/
475 /* Get the file name. */
476 /*====================*/
477
478 if ((fileName = GetFileName(theEnv,"open",1)) == NULL) return(0);
479
480 /*=======================================*/
481 /* Get the logical name to be associated */
482 /* with the opened file. */
483 /*=======================================*/
484
485 logicalName = GetLogicalName(theEnv,2,NULL);
486 if (logicalName == NULL)
487 {
488 SetHaltExecution(theEnv,TRUE);
489 SetEvaluationError(theEnv,TRUE);
490 IllegalLogicalNameMessage(theEnv,"open");
491 return(0);
492 }
493
494 /*==================================*/
495 /* Check to see if the logical name */
496 /* is already in use. */
497 /*==================================*/
498
499 if (FindFile(theEnv,logicalName))
500 {
501 SetHaltExecution(theEnv,TRUE);
502 SetEvaluationError(theEnv,TRUE);
503 PrintErrorID(theEnv,"IOFUN",2,FALSE);
504 EnvPrintRouter(theEnv,WERROR,"Logical name ");
505 EnvPrintRouter(theEnv,WERROR,logicalName);
506 EnvPrintRouter(theEnv,WERROR," already in use.\n");
507 return(0);
508 }
509
510 /*===========================*/
511 /* Get the file access mode. */
512 /*===========================*/
513
514 if (numberOfArguments == 2)
515 { accessMode = "r"; }
516 else if (numberOfArguments == 3)
517 {
518 if (EnvArgTypeCheck(theEnv,"open",3,STRING,&theArgument) == FALSE) return(0);
519 accessMode = DOToString(theArgument);
520 }
521
522 /*=====================================*/
523 /* Check for a valid file access mode. */
524 /*=====================================*/
525
526 if ((strcmp(accessMode,"r") != 0) &&
527 (strcmp(accessMode,"w") != 0) &&
528 (strcmp(accessMode,"a") != 0) &&
529 (strcmp(accessMode,"rb") != 0) &&
530 (strcmp(accessMode,"wb") != 0) &&
531 (strcmp(accessMode,"ab") != 0))
532 {
533 SetHaltExecution(theEnv,TRUE);
534 SetEvaluationError(theEnv,TRUE);
535 ExpectedTypeError1(theEnv,"open",3,"string with value \"r\", \"w\", \"a\", \"rb\", \"wb\", or \"ab\"");
536 return(0);
537 }
538
539 /*================================================*/
540 /* Open the named file and associate it with the */
541 /* specified logical name. Return TRUE if the */
542 /* file was opened successfully, otherwise FALSE. */
543 /*================================================*/
544
545 return(OpenAFile(theEnv,fileName,accessMode,logicalName));
546 }
547
548 /***************************************************************/
549 /* CloseFunction: H/L access routine for the close function. */
550 /***************************************************************/
CloseFunction(void * theEnv)551 globle int CloseFunction(
552 void *theEnv)
553 {
554 int numberOfArguments;
555 const char *logicalName;
556
557 /*======================================*/
558 /* Check for valid number of arguments. */
559 /*======================================*/
560
561 if ((numberOfArguments = EnvArgCountCheck(theEnv,"close",NO_MORE_THAN,1)) == -1) return(0);
562
563 /*=====================================================*/
564 /* If no arguments are specified, then close all files */
565 /* opened with the open command. Return TRUE if all */
566 /* files were closed successfully, otherwise FALSE. */
567 /*=====================================================*/
568
569 if (numberOfArguments == 0) return(CloseAllFiles(theEnv));
570
571 /*================================*/
572 /* Get the logical name argument. */
573 /*================================*/
574
575 logicalName = GetLogicalName(theEnv,1,NULL);
576 if (logicalName == NULL)
577 {
578 IllegalLogicalNameMessage(theEnv,"close");
579 SetHaltExecution(theEnv,TRUE);
580 SetEvaluationError(theEnv,TRUE);
581 return(0);
582 }
583
584 /*========================================================*/
585 /* Close the file associated with the specified logical */
586 /* name. Return TRUE if the file was closed successfully, */
587 /* otherwise false. */
588 /*========================================================*/
589
590 return(CloseFile(theEnv,logicalName));
591 }
592
593 /***************************************/
594 /* GetCharFunction: H/L access routine */
595 /* for the get-char function. */
596 /***************************************/
GetCharFunction(void * theEnv)597 globle int GetCharFunction(
598 void *theEnv)
599 {
600 int numberOfArguments;
601 const char *logicalName;
602
603 if ((numberOfArguments = EnvArgCountCheck(theEnv,"get-char",NO_MORE_THAN,1)) == -1)
604 { return(-1); }
605
606 if (numberOfArguments == 0 )
607 { logicalName = STDIN; }
608 else
609 {
610 logicalName = GetLogicalName(theEnv,1,STDIN);
611 if (logicalName == NULL)
612 {
613 IllegalLogicalNameMessage(theEnv,"get-char");
614 SetHaltExecution(theEnv,TRUE);
615 SetEvaluationError(theEnv,TRUE);
616 return(-1);
617 }
618 }
619
620 if (QueryRouters(theEnv,logicalName) == FALSE)
621 {
622 UnrecognizedRouterMessage(theEnv,logicalName);
623 SetHaltExecution(theEnv,TRUE);
624 SetEvaluationError(theEnv,TRUE);
625 return(-1);
626 }
627
628 return(EnvGetcRouter(theEnv,logicalName));
629 }
630
631 /***************************************/
632 /* PutCharFunction: H/L access routine */
633 /* for the put-char function. */
634 /***************************************/
PutCharFunction(void * theEnv)635 globle void PutCharFunction(
636 void *theEnv)
637 {
638 int numberOfArguments;
639 const char *logicalName;
640 DATA_OBJECT theValue;
641 long long theChar;
642 FILE *theFile;
643
644 if ((numberOfArguments = EnvArgRangeCheck(theEnv,"put-char",1,2)) == -1)
645 { return; }
646
647 /*=======================*/
648 /* Get the logical name. */
649 /*=======================*/
650
651 if (numberOfArguments == 1)
652 { logicalName = STDOUT; }
653 else
654 {
655 logicalName = GetLogicalName(theEnv,1,STDOUT);
656 if (logicalName == NULL)
657 {
658 IllegalLogicalNameMessage(theEnv,"put-char");
659 SetHaltExecution(theEnv,TRUE);
660 SetEvaluationError(theEnv,TRUE);
661 return;
662 }
663 }
664
665 if (QueryRouters(theEnv,logicalName) == FALSE)
666 {
667 UnrecognizedRouterMessage(theEnv,logicalName);
668 SetHaltExecution(theEnv,TRUE);
669 SetEvaluationError(theEnv,TRUE);
670 return;
671 }
672
673 /*===========================*/
674 /* Get the character to put. */
675 /*===========================*/
676
677 if (numberOfArguments == 1)
678 { if (EnvArgTypeCheck(theEnv,"put-char",1,INTEGER,&theValue) == FALSE) return; }
679 else
680 { if (EnvArgTypeCheck(theEnv,"put-char",2,INTEGER,&theValue) == FALSE) return; }
681
682 theChar = DOToLong(theValue);
683
684 /*===================================================*/
685 /* If the "fast load" option is being used, then the */
686 /* logical name is actually a pointer to a file and */
687 /* we can bypass the router and directly output the */
688 /* value. */
689 /*===================================================*/
690
691 theFile = FindFptr(theEnv,logicalName);
692 if (theFile != NULL)
693 { putc((int) theChar,theFile); }
694 }
695
696 /****************************************/
697 /* RemoveFunction: H/L access routine */
698 /* for the remove function. */
699 /****************************************/
RemoveFunction(void * theEnv)700 globle int RemoveFunction(
701 void *theEnv)
702 {
703 const char *theFileName;
704
705 /*======================================*/
706 /* Check for valid number of arguments. */
707 /*======================================*/
708
709 if (EnvArgCountCheck(theEnv,"remove",EXACTLY,1) == -1) return(FALSE);
710
711 /*====================*/
712 /* Get the file name. */
713 /*====================*/
714
715 if ((theFileName = GetFileName(theEnv,"remove",1)) == NULL) return(FALSE);
716
717 /*==============================================*/
718 /* Remove the file. Return TRUE if the file was */
719 /* sucessfully removed, otherwise FALSE. */
720 /*==============================================*/
721
722 return(genremove(theFileName));
723 }
724
725 /****************************************/
726 /* RenameFunction: H/L access routine */
727 /* for the rename function. */
728 /****************************************/
RenameFunction(void * theEnv)729 globle int RenameFunction(
730 void *theEnv)
731 {
732 const char *oldFileName, *newFileName;
733
734 /*========================================*/
735 /* Check for a valid number of arguments. */
736 /*========================================*/
737
738 if (EnvArgCountCheck(theEnv,"rename",EXACTLY,2) == -1) return(FALSE);
739
740 /*===========================*/
741 /* Check for the file names. */
742 /*===========================*/
743
744 if ((oldFileName = GetFileName(theEnv,"rename",1)) == NULL) return(FALSE);
745 if ((newFileName = GetFileName(theEnv,"rename",2)) == NULL) return(FALSE);
746
747 /*==============================================*/
748 /* Rename the file. Return TRUE if the file was */
749 /* sucessfully renamed, otherwise FALSE. */
750 /*==============================================*/
751
752 return(genrename(oldFileName,newFileName));
753 }
754
755 /****************************************/
756 /* FormatFunction: H/L access routine */
757 /* for the format function. */
758 /****************************************/
FormatFunction(void * theEnv)759 globle void *FormatFunction(
760 void *theEnv)
761 {
762 int argCount;
763 size_t start_pos;
764 const char *formatString;
765 const char *logicalName;
766 char formatFlagType;
767 int f_cur_arg = 3;
768 size_t form_pos = 0;
769 char percentBuffer[FLAG_MAX];
770 char *fstr = NULL;
771 size_t fmaxm = 0;
772 size_t fpos = 0;
773 void *hptr;
774 const char *theString;
775
776 /*======================================*/
777 /* Set default return value for errors. */
778 /*======================================*/
779
780 hptr = EnvAddSymbol(theEnv,"");
781
782 /*=========================================*/
783 /* Format requires at least two arguments: */
784 /* a logical name and a format string. */
785 /*=========================================*/
786
787 if ((argCount = EnvArgCountCheck(theEnv,"format",AT_LEAST,2)) == -1)
788 { return(hptr); }
789
790 /*========================================*/
791 /* First argument must be a logical name. */
792 /*========================================*/
793
794 if ((logicalName = GetLogicalName(theEnv,1,STDOUT)) == NULL)
795 {
796 IllegalLogicalNameMessage(theEnv,"format");
797 SetHaltExecution(theEnv,TRUE);
798 SetEvaluationError(theEnv,TRUE);
799 return(hptr);
800 }
801
802 if (strcmp(logicalName,"nil") == 0)
803 { /* do nothing */ }
804 else if (QueryRouters(theEnv,logicalName) == FALSE)
805 {
806 UnrecognizedRouterMessage(theEnv,logicalName);
807 return(hptr);
808 }
809
810 /*=====================================================*/
811 /* Second argument must be a string. The appropriate */
812 /* number of arguments specified by the string must be */
813 /* present in the argument list. */
814 /*=====================================================*/
815
816 if ((formatString = ControlStringCheck(theEnv,argCount)) == NULL)
817 { return (hptr); }
818
819 /*========================================*/
820 /* Search the format string, printing the */
821 /* format flags as they are encountered. */
822 /*========================================*/
823
824 while (formatString[form_pos] != '\0')
825 {
826 if (formatString[form_pos] != '%')
827 {
828 start_pos = form_pos;
829 while ((formatString[form_pos] != '%') &&
830 (formatString[form_pos] != '\0'))
831 { form_pos++; }
832 fstr = AppendNToString(theEnv,&formatString[start_pos],fstr,form_pos-start_pos,&fpos,&fmaxm);
833 }
834 else
835 {
836 form_pos++;
837 formatFlagType = FindFormatFlag(formatString,&form_pos,percentBuffer,FLAG_MAX);
838 if (formatFlagType != ' ')
839 {
840 if ((theString = PrintFormatFlag(theEnv,percentBuffer,f_cur_arg,formatFlagType)) == NULL)
841 {
842 if (fstr != NULL) rm(theEnv,fstr,fmaxm);
843 return (hptr);
844 }
845 fstr = AppendToString(theEnv,theString,fstr,&fpos,&fmaxm);
846 if (fstr == NULL) return(hptr);
847 f_cur_arg++;
848 }
849 else
850 {
851 fstr = AppendToString(theEnv,percentBuffer,fstr,&fpos,&fmaxm);
852 if (fstr == NULL) return(hptr);
853 }
854 }
855 }
856
857 if (fstr != NULL)
858 {
859 hptr = EnvAddSymbol(theEnv,fstr);
860 if (strcmp(logicalName,"nil") != 0) EnvPrintRouter(theEnv,logicalName,fstr);
861 rm(theEnv,fstr,fmaxm);
862 }
863 else
864 { hptr = EnvAddSymbol(theEnv,""); }
865
866 return(hptr);
867 }
868
869 /*********************************************************************/
870 /* ControlStringCheck: Checks the 2nd parameter which is the format */
871 /* control string to see if there are enough matching arguments. */
872 /*********************************************************************/
ControlStringCheck(void * theEnv,int argCount)873 static const char *ControlStringCheck(
874 void *theEnv,
875 int argCount)
876 {
877 DATA_OBJECT t_ptr;
878 const char *str_array;
879 char print_buff[FLAG_MAX];
880 size_t i;
881 int per_count;
882 char formatFlag;
883
884 if (EnvArgTypeCheck(theEnv,"format",2,STRING,&t_ptr) == FALSE) return(NULL);
885
886 per_count = 0;
887 str_array = ValueToString(t_ptr.value);
888 for (i= 0 ; str_array[i] != '\0' ; )
889 {
890 if (str_array[i] == '%')
891 {
892 i++;
893 formatFlag = FindFormatFlag(str_array,&i,print_buff,FLAG_MAX);
894 if (formatFlag == '-')
895 {
896 PrintErrorID(theEnv,"IOFUN",3,FALSE);
897 EnvPrintRouter(theEnv,WERROR,"Invalid format flag \"");
898 EnvPrintRouter(theEnv,WERROR,print_buff);
899 EnvPrintRouter(theEnv,WERROR,"\" specified in format function.\n");
900 SetEvaluationError(theEnv,TRUE);
901 return (NULL);
902 }
903 else if (formatFlag != ' ')
904 { per_count++; }
905 }
906 else
907 { i++; }
908 }
909
910 if (per_count != (argCount - 2))
911 {
912 ExpectedCountError(theEnv,"format",EXACTLY,per_count+2);
913 SetEvaluationError(theEnv,TRUE);
914 return (NULL);
915 }
916
917 return(str_array);
918 }
919
920 /***********************************************/
921 /* FindFormatFlag: This function searches for */
922 /* a format flag in the format string. */
923 /***********************************************/
FindFormatFlag(const char * formatString,size_t * a,char * formatBuffer,size_t bufferMax)924 static char FindFormatFlag(
925 const char *formatString,
926 size_t *a,
927 char *formatBuffer,
928 size_t bufferMax)
929 {
930 char inchar, formatFlagType;
931 size_t copy_pos = 0;
932
933 /*====================================================*/
934 /* Set return values to the default value. A blank */
935 /* character indicates that no format flag was found */
936 /* which requires a parameter. */
937 /*====================================================*/
938
939 formatFlagType = ' ';
940
941 /*=====================================================*/
942 /* The format flags for carriage returns, line feeds, */
943 /* horizontal and vertical tabs, and the percent sign, */
944 /* do not require a parameter. */
945 /*=====================================================*/
946
947 if (formatString[*a] == 'n')
948 {
949 gensprintf(formatBuffer,"\n");
950 (*a)++;
951 return(formatFlagType);
952 }
953 else if (formatString[*a] == 'r')
954 {
955 gensprintf(formatBuffer,"\r");
956 (*a)++;
957 return(formatFlagType);
958 }
959 else if (formatString[*a] == 't')
960 {
961 gensprintf(formatBuffer,"\t");
962 (*a)++;
963 return(formatFlagType);
964 }
965 else if (formatString[*a] == 'v')
966 {
967 gensprintf(formatBuffer,"\v");
968 (*a)++;
969 return(formatFlagType);
970 }
971 else if (formatString[*a] == '%')
972 {
973 gensprintf(formatBuffer,"%%");
974 (*a)++;
975 return(formatFlagType);
976 }
977
978 /*======================================================*/
979 /* Identify the format flag which requires a parameter. */
980 /*======================================================*/
981
982 formatBuffer[copy_pos++] = '%';
983 formatBuffer[copy_pos] = '\0';
984 while ((formatString[*a] != '%') &&
985 (formatString[*a] != '\0') &&
986 (copy_pos < (bufferMax - 5)))
987 {
988 inchar = formatString[*a];
989 (*a)++;
990
991 if ( (inchar == 'd') ||
992 (inchar == 'o') ||
993 (inchar == 'x') ||
994 (inchar == 'u'))
995 {
996 formatFlagType = inchar;
997 formatBuffer[copy_pos++] = 'l';
998 formatBuffer[copy_pos++] = 'l';
999 formatBuffer[copy_pos++] = inchar;
1000 formatBuffer[copy_pos] = '\0';
1001 return(formatFlagType);
1002 }
1003 else if ( (inchar == 'c') ||
1004 (inchar == 's') ||
1005 (inchar == 'e') ||
1006 (inchar == 'f') ||
1007 (inchar == 'g') )
1008 {
1009 formatBuffer[copy_pos++] = inchar;
1010 formatBuffer[copy_pos] = '\0';
1011 formatFlagType = inchar;
1012 return(formatFlagType);
1013 }
1014
1015 /*=======================================================*/
1016 /* If the type hasn't been read, then this should be the */
1017 /* -M.N part of the format specification (where M and N */
1018 /* are integers). */
1019 /*=======================================================*/
1020
1021 if ( (! isdigit(inchar)) &&
1022 (inchar != '.') &&
1023 (inchar != '-') )
1024 {
1025 formatBuffer[copy_pos++] = inchar;
1026 formatBuffer[copy_pos] = '\0';
1027 return('-');
1028 }
1029
1030 formatBuffer[copy_pos++] = inchar;
1031 formatBuffer[copy_pos] = '\0';
1032 }
1033
1034 return(formatFlagType);
1035 }
1036
1037 /**********************************************************************/
1038 /* PrintFormatFlag: Prints out part of the total format string along */
1039 /* with the argument for that part of the format string. */
1040 /**********************************************************************/
PrintFormatFlag(void * theEnv,const char * formatString,int whichArg,int formatType)1041 static const char *PrintFormatFlag(
1042 void *theEnv,
1043 const char *formatString,
1044 int whichArg,
1045 int formatType)
1046 {
1047 DATA_OBJECT theResult;
1048 const char *theString;
1049 char *printBuffer;
1050 size_t theLength;
1051 void *oldLocale;
1052
1053 /*=================*/
1054 /* String argument */
1055 /*=================*/
1056
1057 switch (formatType)
1058 {
1059 case 's':
1060 if (EnvArgTypeCheck(theEnv,"format",whichArg,SYMBOL_OR_STRING,&theResult) == FALSE) return(NULL);
1061 theLength = strlen(formatString) + strlen(ValueToString(theResult.value)) + 200;
1062 printBuffer = (char *) gm2(theEnv,(sizeof(char) * theLength));
1063 gensprintf(printBuffer,formatString,ValueToString(theResult.value));
1064 break;
1065
1066 case 'c':
1067 EnvRtnUnknown(theEnv,whichArg,&theResult);
1068 if ((GetType(theResult) == STRING) ||
1069 (GetType(theResult) == SYMBOL))
1070 {
1071 theLength = strlen(formatString) + 200;
1072 printBuffer = (char *) gm2(theEnv,(sizeof(char) * theLength));
1073 gensprintf(printBuffer,formatString,(ValueToString(theResult.value))[0]);
1074 }
1075 else if (GetType(theResult) == INTEGER)
1076 {
1077 theLength = strlen(formatString) + 200;
1078 printBuffer = (char *) gm2(theEnv,(sizeof(char) * theLength));
1079 gensprintf(printBuffer,formatString,(char) DOToLong(theResult));
1080 }
1081 else
1082 {
1083 ExpectedTypeError1(theEnv,"format",whichArg,"symbol, string, or integer");
1084 return(NULL);
1085 }
1086 break;
1087
1088 case 'd':
1089 case 'x':
1090 case 'o':
1091 case 'u':
1092 if (EnvArgTypeCheck(theEnv,"format",whichArg,INTEGER_OR_FLOAT,&theResult) == FALSE) return(NULL);
1093 theLength = strlen(formatString) + 200;
1094 printBuffer = (char *) gm2(theEnv,(sizeof(char) * theLength));
1095
1096 oldLocale = EnvAddSymbol(theEnv,setlocale(LC_NUMERIC,NULL));
1097 setlocale(LC_NUMERIC,ValueToString(IOFunctionData(theEnv)->locale));
1098
1099 if (GetType(theResult) == FLOAT)
1100 { gensprintf(printBuffer,formatString,(long long) ValueToDouble(theResult.value)); }
1101 else
1102 { gensprintf(printBuffer,formatString,(long long) ValueToLong(theResult.value)); }
1103
1104 setlocale(LC_NUMERIC,ValueToString(oldLocale));
1105 break;
1106
1107 case 'f':
1108 case 'g':
1109 case 'e':
1110 if (EnvArgTypeCheck(theEnv,"format",whichArg,INTEGER_OR_FLOAT,&theResult) == FALSE) return(NULL);
1111 theLength = strlen(formatString) + 200;
1112 printBuffer = (char *) gm2(theEnv,(sizeof(char) * theLength));
1113
1114 oldLocale = EnvAddSymbol(theEnv,setlocale(LC_NUMERIC,NULL));
1115
1116 setlocale(LC_NUMERIC,ValueToString(IOFunctionData(theEnv)->locale));
1117
1118 if (GetType(theResult) == FLOAT)
1119 { gensprintf(printBuffer,formatString,ValueToDouble(theResult.value)); }
1120 else
1121 { gensprintf(printBuffer,formatString,(double) ValueToLong(theResult.value)); }
1122
1123 setlocale(LC_NUMERIC,ValueToString(oldLocale));
1124
1125 break;
1126
1127 default:
1128 EnvPrintRouter(theEnv,WERROR," Error in format, the conversion character");
1129 EnvPrintRouter(theEnv,WERROR," for formatted output is not valid\n");
1130 return(FALSE);
1131 }
1132
1133 theString = ValueToString(EnvAddSymbol(theEnv,printBuffer));
1134 rm(theEnv,printBuffer,sizeof(char) * theLength);
1135 return(theString);
1136 }
1137
1138 /******************************************/
1139 /* ReadlineFunction: H/L access routine */
1140 /* for the readline function. */
1141 /******************************************/
ReadlineFunction(void * theEnv,DATA_OBJECT_PTR returnValue)1142 globle void ReadlineFunction(
1143 void *theEnv,
1144 DATA_OBJECT_PTR returnValue)
1145 {
1146 char *buffer;
1147 size_t line_max = 0;
1148 int numberOfArguments;
1149 const char *logicalName;
1150
1151 returnValue->type = STRING;
1152
1153 if ((numberOfArguments = EnvArgCountCheck(theEnv,"readline",NO_MORE_THAN,1)) == -1)
1154 {
1155 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
1156 return;
1157 }
1158
1159 if (numberOfArguments == 0 )
1160 { logicalName = STDIN; }
1161 else
1162 {
1163 logicalName = GetLogicalName(theEnv,1,STDIN);
1164 if (logicalName == NULL)
1165 {
1166 IllegalLogicalNameMessage(theEnv,"readline");
1167 SetHaltExecution(theEnv,TRUE);
1168 SetEvaluationError(theEnv,TRUE);
1169 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
1170 return;
1171 }
1172 }
1173
1174 if (QueryRouters(theEnv,logicalName) == FALSE)
1175 {
1176 UnrecognizedRouterMessage(theEnv,logicalName);
1177 SetHaltExecution(theEnv,TRUE);
1178 SetEvaluationError(theEnv,TRUE);
1179 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
1180 return;
1181 }
1182
1183 RouterData(theEnv)->CommandBufferInputCount = 0;
1184 RouterData(theEnv)->AwaitingInput = TRUE;
1185 buffer = FillBuffer(theEnv,logicalName,&RouterData(theEnv)->CommandBufferInputCount,&line_max);
1186 RouterData(theEnv)->CommandBufferInputCount = 0;
1187 RouterData(theEnv)->AwaitingInput = FALSE;
1188
1189 if (GetHaltExecution(theEnv))
1190 {
1191 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
1192 if (buffer != NULL) rm(theEnv,buffer,(int) sizeof (char) * line_max);
1193 return;
1194 }
1195
1196 if (buffer == NULL)
1197 {
1198 returnValue->value = (void *) EnvAddSymbol(theEnv,"EOF");
1199 returnValue->type = SYMBOL;
1200 return;
1201 }
1202
1203 returnValue->value = (void *) EnvAddSymbol(theEnv,buffer);
1204 rm(theEnv,buffer,(int) sizeof (char) * line_max);
1205 return;
1206 }
1207
1208 /*************************************************************/
1209 /* FillBuffer: Read characters from a specified logical name */
1210 /* and places them into a buffer until a carriage return */
1211 /* or end-of-file character is read. */
1212 /*************************************************************/
FillBuffer(void * theEnv,const char * logicalName,size_t * currentPosition,size_t * maximumSize)1213 static char *FillBuffer(
1214 void *theEnv,
1215 const char *logicalName,
1216 size_t *currentPosition,
1217 size_t *maximumSize)
1218 {
1219 int c;
1220 char *buf = NULL;
1221
1222 /*================================*/
1223 /* Read until end of line or eof. */
1224 /*================================*/
1225
1226 c = EnvGetcRouter(theEnv,logicalName);
1227
1228 if (c == EOF)
1229 { return(NULL); }
1230
1231 /*==================================*/
1232 /* Grab characters until cr or eof. */
1233 /*==================================*/
1234
1235 while ((c != '\n') && (c != '\r') && (c != EOF) &&
1236 (! GetHaltExecution(theEnv)))
1237 {
1238 buf = ExpandStringWithChar(theEnv,c,buf,currentPosition,maximumSize,*maximumSize+80);
1239 c = EnvGetcRouter(theEnv,logicalName);
1240 }
1241
1242 /*==================*/
1243 /* Add closing EOS. */
1244 /*==================*/
1245
1246 buf = ExpandStringWithChar(theEnv,EOS,buf,currentPosition,maximumSize,*maximumSize+80);
1247 return (buf);
1248 }
1249
1250 /*****************************************/
1251 /* SetLocaleFunction: H/L access routine */
1252 /* for the set-locale function. */
1253 /*****************************************/
SetLocaleFunction(void * theEnv,DATA_OBJECT_PTR returnValue)1254 globle void SetLocaleFunction(
1255 void *theEnv,
1256 DATA_OBJECT_PTR returnValue)
1257 {
1258 DATA_OBJECT theResult;
1259 int numArgs;
1260
1261 /*======================================*/
1262 /* Check for valid number of arguments. */
1263 /*======================================*/
1264
1265 if ((numArgs = EnvArgCountCheck(theEnv,"set-locale",NO_MORE_THAN,1)) == -1)
1266 {
1267 returnValue->type = SYMBOL;
1268 returnValue->value = EnvFalseSymbol(theEnv);
1269 return;
1270 }
1271
1272 /*=================================*/
1273 /* If there are no arguments, just */
1274 /* return the current locale. */
1275 /*=================================*/
1276
1277 if (numArgs == 0)
1278 {
1279 returnValue->type = STRING;
1280 returnValue->value = IOFunctionData(theEnv)->locale;
1281 return;
1282 }
1283
1284 /*=================*/
1285 /* Get the locale. */
1286 /*=================*/
1287
1288 if (EnvArgTypeCheck(theEnv,"set-locale",1,STRING,&theResult) == FALSE)
1289 {
1290 returnValue->type = SYMBOL;
1291 returnValue->value = EnvFalseSymbol(theEnv);
1292 return;
1293 }
1294
1295 /*=====================================*/
1296 /* Return the old value of the locale. */
1297 /*=====================================*/
1298
1299 returnValue->type = STRING;
1300 returnValue->value = IOFunctionData(theEnv)->locale;
1301
1302 /*======================================================*/
1303 /* Change the value of the locale to the one specified. */
1304 /*======================================================*/
1305
1306 DecrementSymbolCount(theEnv,(struct symbolHashNode *) IOFunctionData(theEnv)->locale);
1307 IOFunctionData(theEnv)->locale = DOToPointer(theResult);
1308 IncrementSymbolCount(IOFunctionData(theEnv)->locale);
1309 }
1310
1311 /******************************************/
1312 /* ReadNumberFunction: H/L access routine */
1313 /* for the read-number function. */
1314 /******************************************/
ReadNumberFunction(void * theEnv,DATA_OBJECT_PTR returnValue)1315 globle void ReadNumberFunction(
1316 void *theEnv,
1317 DATA_OBJECT_PTR returnValue)
1318 {
1319 struct token theToken;
1320 int numberOfArguments;
1321 const char *logicalName = NULL;
1322
1323 /*===============================================*/
1324 /* Check for an appropriate number of arguments. */
1325 /*===============================================*/
1326
1327 if ((numberOfArguments = EnvArgCountCheck(theEnv,"read",NO_MORE_THAN,1)) == -1)
1328 {
1329 returnValue->type = STRING;
1330 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
1331 return;
1332 }
1333
1334 /*======================================================*/
1335 /* Determine the logical name from which input is read. */
1336 /*======================================================*/
1337
1338 if (numberOfArguments == 0)
1339 { logicalName = STDIN; }
1340 else if (numberOfArguments == 1)
1341 {
1342 logicalName = GetLogicalName(theEnv,1,STDIN);
1343 if (logicalName == NULL)
1344 {
1345 IllegalLogicalNameMessage(theEnv,"read");
1346 SetHaltExecution(theEnv,TRUE);
1347 SetEvaluationError(theEnv,TRUE);
1348 returnValue->type = STRING;
1349 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
1350 return;
1351 }
1352 }
1353
1354 /*============================================*/
1355 /* Check to see that the logical name exists. */
1356 /*============================================*/
1357
1358 if (QueryRouters(theEnv,logicalName) == FALSE)
1359 {
1360 UnrecognizedRouterMessage(theEnv,logicalName);
1361 SetHaltExecution(theEnv,TRUE);
1362 SetEvaluationError(theEnv,TRUE);
1363 returnValue->type = STRING;
1364 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
1365 return;
1366 }
1367
1368 /*=======================================*/
1369 /* Collect input into string if the read */
1370 /* source is stdin, else just get token. */
1371 /*=======================================*/
1372
1373 if (strcmp(logicalName,STDIN) == 0)
1374 { ReadNumber(theEnv,logicalName,&theToken,TRUE); }
1375 else
1376 { ReadNumber(theEnv,logicalName,&theToken,FALSE); }
1377
1378 RouterData(theEnv)->CommandBufferInputCount = 0;
1379 RouterData(theEnv)->AwaitingInput = FALSE;
1380
1381 /*====================================================*/
1382 /* Copy the token to the return value data structure. */
1383 /*====================================================*/
1384
1385 returnValue->type = theToken.type;
1386 if ((theToken.type == FLOAT) || (theToken.type == STRING) ||
1387 #if OBJECT_SYSTEM
1388 (theToken.type == INSTANCE_NAME) ||
1389 #endif
1390 (theToken.type == SYMBOL) || (theToken.type == INTEGER))
1391 { returnValue->value = theToken.value; }
1392 else if (theToken.type == STOP)
1393 {
1394 returnValue->type = SYMBOL;
1395 returnValue->value = (void *) EnvAddSymbol(theEnv,"EOF");
1396 }
1397 else if (theToken.type == UNKNOWN_VALUE)
1398 {
1399 returnValue->type = STRING;
1400 returnValue->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
1401 }
1402 else
1403 {
1404 returnValue->type = STRING;
1405 returnValue->value = (void *) EnvAddSymbol(theEnv,theToken.printForm);
1406 }
1407
1408 return;
1409 }
1410
1411 /********************************************/
1412 /* ReadNumber: Special routine used by the */
1413 /* read-number function to read a number. */
1414 /********************************************/
ReadNumber(void * theEnv,const char * logicalName,struct token * theToken,int isStdin)1415 static void ReadNumber(
1416 void *theEnv,
1417 const char *logicalName,
1418 struct token *theToken,
1419 int isStdin)
1420 {
1421 char *inputString;
1422 char *charPtr = NULL;
1423 size_t inputStringSize;
1424 int inchar;
1425 long long theLong;
1426 double theDouble;
1427 void *oldLocale;
1428
1429 theToken->type = STOP;
1430
1431 /*===========================================*/
1432 /* Initialize the variables used for storing */
1433 /* the characters retrieved from stdin. */
1434 /*===========================================*/
1435
1436 inputString = NULL;
1437 RouterData(theEnv)->CommandBufferInputCount = 0;
1438 RouterData(theEnv)->AwaitingInput = TRUE;
1439 inputStringSize = 0;
1440 inchar = EnvGetcRouter(theEnv,logicalName);
1441
1442 /*====================================*/
1443 /* Skip whitespace before any number. */
1444 /*====================================*/
1445
1446 while (isspace(inchar) && (inchar != EOF) &&
1447 (! GetHaltExecution(theEnv)))
1448 { inchar = EnvGetcRouter(theEnv,logicalName); }
1449
1450 /*=============================================================*/
1451 /* Continue reading characters until whitespace is found again */
1452 /* (for anything other than stdin) or a CR/LF (for stdin). */
1453 /*=============================================================*/
1454
1455 while ((((! isStdin) && (! isspace(inchar))) ||
1456 (isStdin && (inchar != '\n') && (inchar != '\r'))) &&
1457 (inchar != EOF) &&
1458 (! GetHaltExecution(theEnv)))
1459 {
1460 inputString = ExpandStringWithChar(theEnv,inchar,inputString,&RouterData(theEnv)->CommandBufferInputCount,
1461 &inputStringSize,inputStringSize + 80);
1462 inchar = EnvGetcRouter(theEnv,logicalName);
1463 }
1464
1465 /*===========================================*/
1466 /* Pressing control-c (or comparable action) */
1467 /* aborts the read-number function. */
1468 /*===========================================*/
1469
1470 if (GetHaltExecution(theEnv))
1471 {
1472 theToken->type = STRING;
1473 theToken->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
1474 if (inputStringSize > 0) rm(theEnv,inputString,inputStringSize);
1475 return;
1476 }
1477
1478 /*====================================================*/
1479 /* Return the EOF symbol if the end of file for stdin */
1480 /* has been encountered. This typically won't occur, */
1481 /* but is possible (for example by pressing control-d */
1482 /* in the UNIX operating system). */
1483 /*====================================================*/
1484
1485 if (inchar == EOF)
1486 {
1487 theToken->type = SYMBOL;
1488 theToken->value = (void *) EnvAddSymbol(theEnv,"EOF");
1489 if (inputStringSize > 0) rm(theEnv,inputString,inputStringSize);
1490 return;
1491 }
1492
1493 /*==================================================*/
1494 /* Open a string input source using the characters */
1495 /* retrieved from stdin and extract the first token */
1496 /* contained in the string. */
1497 /*==================================================*/
1498
1499 /*=======================================*/
1500 /* Change the locale so that numbers are */
1501 /* converted using the localized format. */
1502 /*=======================================*/
1503
1504 oldLocale = EnvAddSymbol(theEnv,setlocale(LC_NUMERIC,NULL));
1505 setlocale(LC_NUMERIC,ValueToString(IOFunctionData(theEnv)->locale));
1506
1507 /*========================================*/
1508 /* Try to parse the number as a long. The */
1509 /* terminating character must either be */
1510 /* white space or the string terminator. */
1511 /*========================================*/
1512
1513 #if WIN_MVC
1514 theLong = _strtoi64(inputString,&charPtr,10);
1515 #else
1516 theLong = strtoll(inputString,&charPtr,10);
1517 #endif
1518
1519 if ((charPtr != inputString) &&
1520 (isspace(*charPtr) || (*charPtr == '\0')))
1521 {
1522 theToken->type = INTEGER;
1523 theToken->value = (void *) EnvAddLong(theEnv,theLong);
1524 if (inputStringSize > 0) rm(theEnv,inputString,inputStringSize);
1525 setlocale(LC_NUMERIC,ValueToString(oldLocale));
1526 return;
1527 }
1528
1529 /*==========================================*/
1530 /* Try to parse the number as a double. The */
1531 /* terminating character must either be */
1532 /* white space or the string terminator. */
1533 /*==========================================*/
1534
1535 theDouble = strtod(inputString,&charPtr);
1536 if ((charPtr != inputString) &&
1537 (isspace(*charPtr) || (*charPtr == '\0')))
1538 {
1539 theToken->type = FLOAT;
1540 theToken->value = (void *) EnvAddDouble(theEnv,theDouble);
1541 if (inputStringSize > 0) rm(theEnv,inputString,inputStringSize);
1542 setlocale(LC_NUMERIC,ValueToString(oldLocale));
1543 return;
1544 }
1545
1546 /*============================================*/
1547 /* Restore the "C" locale so that any parsing */
1548 /* of numbers uses the C format. */
1549 /*============================================*/
1550
1551 setlocale(LC_NUMERIC,ValueToString(oldLocale));
1552
1553 /*=========================================*/
1554 /* Return "*** READ ERROR ***" to indicate */
1555 /* a number was not successfully parsed. */
1556 /*=========================================*/
1557
1558 theToken->type = STRING;
1559 theToken->value = (void *) EnvAddSymbol(theEnv,"*** READ ERROR ***");
1560 }
1561
1562 #endif
1563
1564