1 /* newlisp.c --- entry point and main functions for newLISP
2
3
4 Copyright (C) 2016 Lutz Mueller
5
6 This program is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this program. If not, see <http://www.gnu.org/licenses/>.
18 */
19
20 #include "newlisp.h"
21 #include "protos.h"
22 #include "primes.h"
23
24 #ifdef WINDOWS
25 #include <winsock2.h>
26 #else
27 #include <sys/socket.h>
28 #endif
29
30 #ifdef READLINE
31 #include <readline/readline.h>
32 /* take following line out on Slackware Linux */
33 #include <readline/history.h>
34 #endif /* end READLINE */
35
36 #ifdef SUPPORT_UTF8
37 #include <wctype.h>
38 #endif
39
40 #define freeMemory free
41
42 #define INIT_FILE "init.lsp"
43
44 #ifdef WINDOWS
45 #define fprintf win_fprintf
46 #define fgets win_fgets
47 #define fclose win_fclose
48 #endif
49
50 #ifdef LIBRARY
51 extern STREAM libStrStream;
52 int newlispLibConsoleFlag = 0;
53 #endif
54
55 #if defined(LINUX) || defined(KFREEBSD)
56 #ifdef ANDROID
57 int opsys = 11;
58 #else
59 int opsys = 1;
60 #endif
61 #endif
62
63 #ifdef _BSD
64 int opsys = 2;
65 #endif
66
67 #ifdef MAC_OSX
68 #ifdef EMSCRIPTEN
69 int opsys = 11;
70 #else
71 int opsys = 3;
72 #endif
73 #endif
74
75 #ifdef SOLARIS
76 int opsys = 4;
77 #endif
78
79 #ifdef WINDOWS
80 int opsys = 6;
81 #endif
82
83 #ifdef OS2
84 int opsys = 7;
85 #endif
86
87 #ifdef CYGWIN
88 int opsys = 8;
89 #endif
90
91 #ifdef TRU64
92 int opsys = 9;
93 #endif
94
95 #ifdef AIX
96 int opsys = 10;
97 #endif
98
99
100 /* opsys = 11 taken for ANDROID; see LINUX */
101
102 int bigEndian = 1; /* gets set in main() */
103
104 int version = 10705;
105
106 char copyright[]=
107 "\nnewLISP v.10.7.5 Copyright (c) 2016 Lutz Mueller. All rights reserved.\n\n%s\n\n";
108
109 #ifndef NEWLISP64
110 #ifdef SUPPORT_UTF8
111 char banner[]=
112 "newLISP v.10.7.5 32-bit on %s IPv4/6 UTF-8%s%s\n\n";
113 #else
114 char banner[]=
115 "newLISP v.10.7.5 32-bit on %s IPv4/6%s%s\n\n";
116 #endif
117 #else /* NEWLISP64 */
118 #ifdef SUPPORT_UTF8
119 char banner[]=
120 "newLISP v.10.7.5 64-bit on %s IPv4/6 UTF-8%s%s\n\n";
121 #else
122 char banner[]=
123 "newLISP v.10.7.5 64-bit on %s IPv4/6%s%s\n\n";
124 #endif
125 #endif /* NEWLISP64 */
126
127 char banner2[]= ", options: newlisp -h";
128
129 void linkSource(char *, char *, char *);
130 char linkOffset[] = "&&&&@@@@";
131 char preLoad[] =
132 #ifdef EMSCRIPTEN
133 "(set (global 'module) (fn ($x) (load (append {/newlisp-js/} $x))))"
134 #else
135 "(set (global 'module) (fn ($x) (load (append (env {NEWLISPDIR}) {/modules/} $x))))"
136 #endif
137 "(context 'Tree) (constant 'Tree:Tree) (context MAIN)"
138 "(define (Class:Class) (cons (context) (args)))";
139 void printHelpText(void);
140 #ifdef READLINE
141 char ** newlisp_completion (char * text, int start, int end);
142 #endif
143 /* --------------------- globals -------------------------------------- */
144
145 /* interactive command line */
146
147 int isTTY = FALSE;
148 int daemonMode = 0;
149
150 int noPromptMode = 0;
151 int forcePromptMode = 0;
152 int httpMode = 0;
153 int httpSafe = 0;
154 int evalSilent = 0;
155
156
157 #ifdef WINDOWS
158 int IOchannelIsSocketStream = 0;
159 #endif
160 FILE * IOchannel;
161 char * IOdomain = NULL;
162 int IOport = 0;
163 int connectionTimeout = 0;
164
165 int logTraffic = 0;
166 #define LOG_LESS 1
167 #define LOG_MORE 2
168
169 /* initialization */
170 int MAX_CPU_STACK = 0x800;
171 int MAX_ENV_STACK;
172 int MAX_RESULT_STACK;
173 #define MAX_OBJECT_STACK 64
174 #ifndef NEWLISP64
175 INT MAX_CELL_COUNT = 0x10000000;
176 #else
177 INT MAX_CELL_COUNT = 0x800000000000000LL;
178 #endif
179 INT blockCount = 0;
180
181 CELL * firstFreeCell = NULL;
182
183 CELL * nilCell;
184 CELL * trueCell;
185 CELL * lastCellCopied;
186 CELL * countCell;
187 SYMBOL * nilSymbol;
188 SYMBOL * trueSymbol;
189 SYMBOL * starSymbol;
190 SYMBOL * plusSymbol;
191 SYMBOL * questionSymbol;
192 SYMBOL * atSymbol;
193 SYMBOL * currentFunc;
194 SYMBOL * argsSymbol;
195 SYMBOL * mainArgsSymbol;
196 SYMBOL * listIdxSymbol;
197 SYMBOL * itSymbol;
198 SYMBOL * sysxSymbol;
199 SYMBOL * countSymbol;
200 SYMBOL * beginSymbol;
201 SYMBOL * expandSymbol;
202
203 SYMBOL * sysSymbol[MAX_REGEX_EXP];
204
205 SYMBOL * currentContext = NULL;
206 SYMBOL * mainContext = NULL;
207 SYMBOL * errorEvent;
208 SYMBOL * timerEvent;
209 SYMBOL * promptEvent;
210 SYMBOL * commandEvent;
211 SYMBOL * transferEvent;
212 SYMBOL * readerEvent;
213
214 SYMBOL * symHandler[32];
215 int currentSignal = 0;
216
217 SYMBOL * symbolCheck = NULL;
218 CELL * stringCell = NULL;
219 void * stringIndexPtr = NULL;
220
221 jmp_buf errorJump;
222
223 char lc_decimal_point;
224
225 /* error and exception handling */
226
227 #define EXCEPTION_THROW -1
228 int errorReg = 0;
229 CELL * throwResult;
230
231 /* buffers for read-line and error reporting */
232 STREAM readLineStream;
233 STREAM errorStream;
234
235 /* compiler */
236
237 size_t cellCount = 0;
238 size_t symbolCount = 0;
239
240 int parStackCounter = 0;
241
242 /* expression evaluation */
243
244 static CELL * (*evalFunc)(CELL *) = NULL;
245
246 UINT * envStack = NULL;
247 UINT * envStackIdx;
248 UINT * envStackTop;
249 UINT * resultStack = NULL;
250 UINT * resultStackIdx;
251 UINT * resultStackTop;
252 UINT * lambdaStack = NULL;
253 UINT * lambdaStackIdx;
254
255 /* internal dummy to carry FOOP object */
256 SYMBOL objSymbol = {SYMBOL_GLOBAL | SYMBOL_BUILTIN,
257 0, "container of (self)", 0, NULL, NULL, NULL, NULL};
258 CELL * objCell;
259
260 extern PRIMITIVE primitive[];
261
262 /* debugger in nl-debug.c */
263 extern char debugPreStr[];
264 extern char debugPostStr[];
265 extern CELL * debugPrintCell;
266
267 int traceFlag = 0;
268 int evalCatchFlag = 0;
269 int recursionCount = 0;
270
271 int prettyPrintPars = 0;
272 int prettyPrintCurrent = 0;
273 int prettyPrintFlags = 0;
274 int prettyPrintLength = 0;
275 char * prettyPrintTab = " ";
276 char * prettyPrintFloat = "%1.16g";
277 #define MAX_PRETTY_PRINT_LENGTH 80
278 UINT prettyPrintMaxLength = MAX_PRETTY_PRINT_LENGTH;
279 int stringOutputRaw = TRUE;
280
281 #define pushLambda(A) (*(lambdaStackIdx++) = (UINT)(A))
282
283 int pushResultFlag = TRUE;
284
285 char startupDir[PATH_MAX]; /* start up directory, if defined via -w */
286 char * tempDir; /* /tmp on unix or geten("TMP") on Windows */
287 char logFile[PATH_MAX]; /* logFile, is define with -l, -L */
288
289 /* nl-filesys.c */
290 int pagesize;
291
292 /* ============================== MAIN ================================ */
293
294 #ifndef EMSCRIPTEN
295 /*
296 void setupSignalHandler(int sig, void (* handler)(int))
297 {
298 static struct sigaction sig_act;
299 sig_act.sa_handler = handler;
300 sigemptyset(&sig_act.sa_mask);
301 sig_act.sa_flags = SA_RESTART | SA_NOCLDSTOP;
302 if(sigaction(sig, &sig_act, 0) != 0)
303 printf("Error setting signal:%d handler\n", sig);
304 }
305 */
setupSignalHandler(int sig,void (* handler)(int))306 void setupSignalHandler(int sig, void (* handler)(int))
307 {
308 if(signal(sig, handler) == SIG_ERR)
309 printf("Error setting signal:%d handler\n", sig);
310 }
311
312 #if defined(SOLARIS) || defined(TRU64) || defined(AIX)
sigpipe_handler(int sig)313 void sigpipe_handler(int sig)
314 {
315 setupSignalHandler(SIGPIPE, sigpipe_handler);
316 }
317
sigchld_handler(int sig)318 void sigchld_handler(int sig)
319 {
320 waitpid(-1, (int *)0, WNOHANG);
321 }
322
ctrlC_handler(int sig)323 void ctrlC_handler(int sig)
324 {
325 char chr;
326
327 setupSignalHandler(SIGINT, ctrlC_handler);
328
329 traceFlag |= TRACE_SIGINT;
330
331 printErrorMessage(ERR_SIGINT, NULL, 0);
332 printf("%s", "(c)ontinue, e(x)it, (r)eset:");
333 fflush(NULL);
334 chr = getchar();
335 if(chr == 'x') exit(1);
336 if(chr == 'c') traceFlag &= ~TRACE_SIGINT;
337 }
338
339
sigalrm_handler(int sig)340 void sigalrm_handler(int sig)
341 {
342 setupSignalHandler(sig, sigalrm_handler);
343 /* check if not sitting idle */
344 if(recursionCount)
345 traceFlag |= TRACE_TIMER;
346 else /* if idle */
347 executeSymbol(timerEvent, NULL, NULL);
348 }
349
350 #endif /* SOLARIS, TRUE64, AIX */
351
352
setupAllSignals(void)353 void setupAllSignals(void)
354 {
355 #if defined(SOLARIS) || defined(TRU64) || defined(AIX)
356 setupSignalHandler(SIGINT, ctrlC_handler);
357 #else
358 setupSignalHandler(SIGINT, signal_handler);
359 #endif
360
361 #ifndef WINDOWS
362
363 #if defined(SOLARIS) || defined(TRU64) || defined(AIX)
364 setupSignalHandler(SIGALRM, sigalrm_handler);
365 setupSignalHandler(SIGVTALRM, sigalrm_handler);
366 setupSignalHandler(SIGPROF, sigalrm_handler);
367 setupSignalHandler(SIGPIPE, sigpipe_handler);
368 setupSignalHandler(SIGCHLD, sigchld_handler);
369 #else
370 setupSignalHandler(SIGALRM, signal_handler);
371 setupSignalHandler(SIGVTALRM, signal_handler);
372 setupSignalHandler(SIGPROF, signal_handler);
373 setupSignalHandler(SIGPIPE, signal_handler);
374 setupSignalHandler(SIGCHLD, signal_handler);
375 #endif
376
377 #endif
378 }
379
signal_handler(int sig)380 void signal_handler(int sig)
381 {
382 #ifndef WINDOWS
383 char chr;
384 #endif
385
386 if(sig > 32 || sig < 1) return;
387
388 #if defined(SOLARIS) || defined(TRU64) || defined(AIX)
389 switch(sig)
390 {
391 case SIGALRM:
392 case SIGVTALRM:
393 case SIGPROF:
394 setupSignalHandler(sig, sigalrm_handler);
395 break;
396 case SIGPIPE:
397 setupSignalHandler(SIGPIPE, sigpipe_handler);
398 break;
399 case SIGCHLD:
400 setupSignalHandler(SIGCHLD, sigchld_handler);
401 break;
402 }
403 #else
404 setupSignalHandler(sig, signal_handler);
405 #endif
406
407 if(symHandler[sig - 1] != nilSymbol)
408 {
409 if(recursionCount)
410 {
411 currentSignal = sig;
412 traceFlag |= TRACE_SIGNAL;
413 return;
414 }
415 else
416 {
417 executeSymbol(symHandler[sig-1], stuffInteger(sig), NULL);
418 return;
419 }
420 }
421
422 switch(sig)
423 {
424 case SIGINT:
425 printErrorMessage(ERR_SIGINT, NULL, 0);
426
427 #ifdef WINDOWS
428 traceFlag |= TRACE_SIGINT;
429 #else
430 printf("%s", "\n(c)ontinue, (d)ebug, e(x)it, (r)eset:");
431 fflush(NULL);
432 chr = getchar();
433 if(chr == 'x') exit(1);
434 if(chr == 'd')
435 {
436 traceFlag &= ~TRACE_SIGINT;
437 openTrace();
438 }
439 if(chr == 'r') traceFlag |= TRACE_SIGINT;
440 break;
441 case SIGPIPE:
442 break;
443 case SIGALRM:
444 case SIGVTALRM:
445 case SIGPROF:
446 /* check if not sitting idle */
447 if(recursionCount)
448 traceFlag |= TRACE_TIMER;
449 else /* if idle */
450 executeSymbol(timerEvent, NULL, NULL);
451 break;
452 case SIGCHLD:
453 waitpid(-1, (int *)0, WNOHANG);
454 #endif
455 break;
456 default:
457 return;
458 }
459 }
460 #endif /* no EMSCRIPTEN */
461
which(char * name,char * buff)462 char * which(char * name, char * buff)
463 {
464 char *path_list, *test, *tmp, *path_parsed;
465 struct stat filestat;
466 int count = 1;
467 int i, len, nlen;
468 int found = FALSE;
469
470 path_list = getenv("PATH");
471 if (!path_list) path_list = "/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin";
472
473 len = strlen(path_list);
474 nlen = strlen(name);
475 path_parsed = alloca(len + 1);
476 strncpy(path_parsed, path_list, len + 1);
477
478 test = path_parsed;
479 while (TRUE)
480 {
481 #ifdef WINDOWS
482 tmp = strchr(test, ';');
483 #else
484 tmp = strchr(test, ':');
485 #endif
486 if (tmp == NULL) break;
487 *tmp = 0;
488 test = tmp + 1;
489 count++;
490 }
491
492 test = path_parsed;
493 for (i = 0; i < count; i++)
494 {
495 len = strlen(test);
496 if((len + nlen + 2) > PATH_MAX)
497 return(NULL);
498 strncpy(buff, test, len + 1);
499 buff[len] = '/';
500 memcpy(buff + len + 1, name, nlen);
501 buff[len + 1 + nlen] = 0;
502 if (stat (buff, &filestat) == 0 && filestat.st_mode & S_IXUSR)
503 {
504 found = TRUE;
505 break;
506 }
507 test += (len + 1);
508 }
509
510 if(!found) return(NULL);
511 errno = 0;
512 return(buff);
513 }
514
515 #ifndef LIBRARY
loadStartup(char * name)516 void loadStartup(char * name)
517 {
518 char initFile[PATH_MAX];
519 char * envPtr;
520 int len;
521
522 /* normal newLISP start up */
523 if(strncmp(linkOffset + 4, "@@@@", 4) == 0)
524 {
525 if(getenv("HOME"))
526 strncpy(initFile, getenv("HOME"), PATH_MAX - 16);
527 else if(getenv("USERPROFILE"))
528 strncpy(initFile, getenv("USERPROFILE"), PATH_MAX - 16);
529 else if(getenv("DOCUMENT_ROOT"))
530 strncpy(initFile, getenv("DOCUMENT_ROOT"), PATH_MAX - 16);
531
532 len = strlen(initFile);
533 memcpy(initFile + len, "/.", 2);
534 memcpy(initFile + len + 2, INIT_FILE, 8);
535 initFile[len + 2 + 8] = 0;
536 if(loadFile(initFile, 0, 0, mainContext) == NULL)
537 {
538 envPtr = getenv("NEWLISPDIR");
539 if(envPtr)
540 {
541 strncpy(initFile, envPtr, PATH_MAX - 16);
542 len = strlen(envPtr);
543 memcpy(initFile + len, "/", 1);
544 memcpy(initFile + len + 1, INIT_FILE, 8);
545 initFile[len + 1 + 8] = 0;
546 loadFile(initFile, 0, 0, mainContext);
547 }
548 }
549 }
550 /* load part at offset no init.lsp or .init.lsp is loaded */
551 else
552 {
553 #ifdef WINDOWS
554 name = win_getExePath(alloca(MAX_PATH));
555 loadFile(name, *(unsigned int *)linkOffset, 1, mainContext);
556 #else /* if not Win32 get full pathname of file in name */
557 if(strchr(name, '/') == NULL)
558 if((name = which(name, alloca(PATH_MAX))) == NULL)
559 {
560 printf("%s: %s\n", strerror(ENOENT), name);
561 exit(ENOENT);
562 }
563 loadFile(name, *(unsigned int *)linkOffset, 1, mainContext);
564 #endif
565 }
566 }
567 #endif /* LIBRARY */
568
569 #ifdef _BSD
570 struct lconv *localeconv(void);
571 char *setlocale(int, const char *);
572 #endif
573
initLocale(void)574 void initLocale(void)
575 {
576 #ifndef ANDROID
577 struct lconv * lc;
578 #endif
579 char * locale;
580
581 #ifndef SUPPORT_UTF8
582 locale = setlocale(LC_ALL, "C");
583 #else
584 locale = setlocale(LC_ALL, "");
585 #endif
586
587 if (locale != NULL)
588 stringOutputRaw = (strcmp(locale, "C") == 0);
589
590 #ifdef ANDROID
591 lc_decimal_point = '.';
592 #else
593 lc = localeconv();
594 lc_decimal_point = *lc->decimal_point;
595 #endif
596 }
597
598 /* set NEWLISPDIR only if not set already */
initNewlispDir(void)599 void initNewlispDir(void)
600 {
601 #ifdef WINDOWS
602 char * varValue;
603 char * newlispDir;
604 int len;
605
606 if(getenv("NEWLISPDIR") == NULL)
607 {
608 newlispDir = alloca(MAX_PATH);
609 varValue = getenv("PROGRAMFILES");
610 if(varValue != NULL)
611 {
612 len = strlen(varValue);
613 strncpy(newlispDir, varValue, MAX_PATH - 12);
614 memcpy(newlispDir + len, "/newlisp", 8);
615 newlispDir[len + 8] = 0;
616 setenv("NEWLISPDIR", newlispDir, TRUE);
617 }
618 else setenv("NEWLISPDIR", "newlisp", TRUE);
619 }
620 #else
621 if(getenv("NEWLISPDIR") == NULL)
622 setenv("NEWLISPDIR", NEWLISPDIR, TRUE);
623 #endif
624 }
625
initTempDir()626 void initTempDir()
627 {
628 #ifdef WINDOWS
629 if((tempDir = getenv("TMP")) == NULL)
630 {
631 printf("Environment variable TMP not set, assuming /tmp .");
632 tempDir = "/tmp";
633 }
634 #else
635 #ifdef ANDROID
636 tempDir = "/data/tmp";
637 #else /* all UNIX */
638 tempDir = "/tmp";
639 #endif
640 #endif
641 return;
642 }
643
644 #ifndef LIBRARY
getArg(char ** arg,int argc,int * index)645 char * getArg(char * * arg, int argc, int * index)
646 {
647 if(strlen(arg[*index]) > 2)
648 return(arg[*index] + 2);
649
650 if(*index >= (argc - 1))
651 {
652 printf("missing parameter for %s\n", arg[*index]);
653 exit(-1);
654 }
655
656 *index = *index + 1;
657
658 return(arg[*index]);
659 }
660
661 #ifndef WINDOWS
662 char ** MainArgs;
663 #endif
664
getMainArgs(char * mainArgs[])665 CELL * getMainArgs(char * mainArgs[])
666 {
667 CELL * argList;
668 int idx = 0;
669
670 #ifndef WINDOWS
671 MainArgs = mainArgs;
672 #endif
673
674 argList = getCell(CELL_EXPRESSION);
675
676 while(mainArgs[idx] != NULL)
677 addList(argList, stuffString(mainArgs[idx++]));
678
679 return(argList);
680 }
681
682 char * getCommandLine(int batchMode, int * length);
683
main(int argc,char * argv[])684 int main(int argc, char * argv[])
685 {
686 char command[MAX_COMMAND_LINE];
687 STREAM cmdStream = {NULL, NULL, 0, 0, 0};
688 char * cmd;
689 int idx;
690
691 #ifdef WINDOWS
692 WSADATA WSAData;
693 if(WSAStartup(MAKEWORD(2,2), &WSAData) != 0)
694 {
695 printf("Winsocket initialization failed\n");
696 exit(-1);
697 }
698 pagesize = 4096;
699
700 /* replace '_CRT_fmode = _O_BINARY' in nl-filesys.c for 10.4.8, thanks to Kosh */
701 _setmode(_fileno(stdin), _O_BINARY);
702 _setmode(_fileno(stdout), _O_BINARY);
703 _setmode(_fileno(stderr), _O_BINARY);
704 #endif
705
706 #ifdef SUPPORT_UTF8
707 opsys += 128;
708 #endif
709
710 #ifdef NEWLISP64
711 opsys += 256;
712 #endif
713
714 #ifdef FFI
715 opsys += 1024;
716 initFFI();
717 #endif
718
719 #ifndef WINDOWS
720 #ifndef OS2
721 pagesize = getpagesize();
722 #endif
723 tzset();
724 #endif
725
726 #ifdef OS2
727 /* Reset the floating point coprocessor */
728 _fpreset();
729 #endif
730
731 initLocale();
732 initNewlispDir();
733 initTempDir();
734
735 IOchannel = stdin;
736 bigEndian = (*((char *)&bigEndian) == 0);
737
738 initStacks();
739 initialize();
740 initDefaultInAddr();
741
742 #ifdef WINDOWS
743 #ifdef SUPPORT_UTF8
744 {
745 /*
746 command line parameter is MBCS.
747 MBCS -> Unicode(UTF-16) -> UTF-8
748 */
749 char **argv_utf8 = allocMemory((argc + 1)* sizeof(char *)) ;
750 {
751 for(idx = 0 ; idx<argc ; idx++)
752 {
753 WCHAR *p_argvW = ansi_mbcs_to_utf16(argv[idx]) ;
754 char *p_argvU = utf16_to_utf8(p_argvW) ;
755 argv_utf8[idx] = p_argvU ;
756 }
757 argv_utf8[idx] = NULL ;
758 argv = argv_utf8 ;
759 }
760 }
761 #endif
762 #endif
763 mainArgsSymbol->contents = (UINT)getMainArgs(argv);
764
765 if((errorReg = setjmp(errorJump)) != 0)
766 {
767 if((errorEvent != nilSymbol) || (errorReg == ERR_USER_RESET))
768 executeSymbol(errorEvent, NULL, NULL);
769 else exit(-1);
770 goto AFTER_ERROR_ENTRY;
771 }
772
773 setupAllSignals();
774
775 sysEvalString(preLoad, mainContext, nilCell, EVAL_STRING);
776
777 /* loading of init.lsp will be suppressed with -n, -x or -h as first option
778 but is never done when program is link.lsp'd */
779
780 if(argc < 2 || (strncmp(argv[1], "-n", 2) && strncmp(argv[1], "-h", 2)) )
781 {
782 if(!(argc >= 2 && strcmp(argv[1], "-x") == 0))
783 loadStartup(argv[0]);
784 }
785
786 errno = 0;
787
788 if(realpath(".", startupDir) == NULL)
789 fatalError(ERR_IO_ERROR, 0, 0);
790
791 for(idx = 1; idx < argc; idx++)
792 {
793 if(strncmp(argv[idx], "-c", 2) == 0)
794 {
795 noPromptMode = TRUE;
796 continue;
797 }
798
799 if(strncmp(argv[idx], "-C", 2) == 0)
800 {
801 forcePromptMode = TRUE;
802 continue;
803 }
804
805 if(strncmp(argv[idx], "-http", 5) == 0)
806 {
807 noPromptMode = TRUE;
808 httpMode = TRUE;
809 if(strncmp(argv[idx], "-http-safe", 10) == 0)
810 httpSafe = TRUE;
811 continue;
812 }
813
814 if(strncmp(argv[idx], "-s", 2) == 0)
815 {
816 MAX_CPU_STACK = atoi(getArg(argv, argc, &idx));
817
818 if(MAX_CPU_STACK < 1024) MAX_CPU_STACK = 1024;
819 initStacks();
820 continue;
821 }
822
823 if(strncmp(argv[idx], "-p", 2) == 0 || strncmp(argv[idx], "-d", 2) == 0 )
824 {
825 if(strncmp(argv[idx], "-d", 2) == 0)
826 daemonMode = TRUE;
827
828 IOdomain = getArg(argv, argc, &idx);
829 IOport = atoi(IOdomain);
830
831 setupServer(0);
832 continue;
833 }
834
835 if(strncmp(argv[idx], "-t", 2) == 0)
836 {
837 connectionTimeout = atoi(getArg(argv, argc, &idx));
838 continue;
839 }
840
841 if(strncmp(argv[idx], "-l", 2) == 0 || strncmp(argv[idx], "-L", 2) == 0)
842 {
843 logTraffic = (strncmp(argv[idx], "-L", 2) == 0) ? LOG_MORE : LOG_LESS;
844 if(realpath(getArg(argv, argc, &idx), logFile) == NULL)
845 close(openFile(logFile, "w", 0));
846
847 continue;
848 }
849
850 if(strncmp(argv[idx], "-m", 2) == 0)
851 {
852 #ifndef NEWLISP64
853 MAX_CELL_COUNT = abs(0x0010000 * atoi(getArg(argv, argc, &idx)));
854 #else
855 MAX_CELL_COUNT = abs(0x0008000 * atoi(getArg(argv, argc, &idx)));
856 #endif
857 continue;
858 }
859
860 if(strncmp(argv[idx], "-w", 2) == 0)
861 {
862 if(realpath(getArg(argv, argc, &idx), startupDir) == NULL
863 || chdir(startupDir) < 0)
864 fatalError(ERR_WORKING_DIR, 0, 0);
865 continue;
866 }
867
868 if(strcmp(argv[idx], "-6") == 0)
869 {
870 ADDR_FAMILY = AF_INET6;
871 initDefaultInAddr();
872 continue;
873 }
874
875 if(strcmp(argv[idx], "-v") == 0)
876 {
877 varPrintf(OUT_CONSOLE, banner, OSTYPE, LIBFFI, ".");
878 exit(0);
879 }
880
881 if(strncmp(argv[idx], "-e", 2) == 0)
882 {
883 executeCommandLine(getArg(argv, argc, &idx), OUT_CONSOLE, &cmdStream);
884 exit(0);
885 }
886
887 if(strncmp(argv[idx], "-x", 2) == 0)
888 {
889 if(argc == 4)
890 linkSource(argv[0], argv[idx + 1], argv[idx + 2]);
891 exit(0);
892 }
893
894 if(strcmp(argv[idx], "-h") == 0)
895 {
896 printHelpText();
897 exit(0);
898 }
899
900 loadFile(argv[idx], 0, 0, mainContext);
901 }
902
903 AFTER_ERROR_ENTRY:
904
905 if(isatty(fileno(IOchannel)))
906 {
907 isTTY = TRUE;
908 if(!noPromptMode)
909 varPrintf(OUT_CONSOLE, banner, OSTYPE, LIBFFI, banner2);
910 }
911 else
912 {
913 #ifdef WINDOWS
914 if(!IOchannelIsSocketStream)
915 #endif
916 setbuf(IOchannel,0);
917 if(forcePromptMode)
918 varPrintf(OUT_CONSOLE, banner, OSTYPE, LIBFFI, banner2);
919 }
920
921 /* ======================= main entry on reset ====================== */
922
923
924 errorReg = setjmp(errorJump);
925
926 setupAllSignals();
927 reset();
928 initStacks();
929
930 if(errorReg && !isNil((CELL*)errorEvent->contents) )
931 executeSymbol(errorEvent, NULL, NULL);
932
933
934 #ifdef READLINE
935 rl_readline_name = "newlisp";
936 rl_attempted_completion_function = (char ** (*) (const char *, int, int))newlisp_completion;
937 #if defined(LINUX) || defined(_BSD) || defined(KFREEBSD)
938 /* in Bash .inputrc put 'set blink-matching-paren on' */
939 rl_set_paren_blink_timeout(300000); /* 300 ms */
940 #endif
941 #endif
942
943 while(TRUE)
944 {
945 cleanupResults(resultStack);
946 if(isTTY)
947 {
948 cmd = getCommandLine(FALSE, NULL);
949 executeCommandLine(cmd, OUT_CONSOLE, &cmdStream);
950 free(cmd);
951 continue;
952 }
953
954 if(IOchannel != stdin || forcePromptMode)
955 varPrintf(OUT_CONSOLE, "%s", prompt());
956
957 /* daemon mode timeout if nothing read after accepting connection */
958 if(connectionTimeout && IOchannel && daemonMode)
959 {
960 #ifdef WINDOWS
961 if(IOchannelIsSocketStream)
962 if(wait_ready(getSocket(IOchannel), connectionTimeout, 0) == 0)
963 #else
964 if(wait_ready(fileno(IOchannel), connectionTimeout, 0) == 0)
965 #endif
966 {
967 fclose(IOchannel);
968 setupServer(1);
969 continue;
970 }
971 }
972
973 if(IOchannel == NULL || fgets(command, MAX_COMMAND_LINE - 1, IOchannel) == NULL)
974 {
975 if(!daemonMode) exit(1);
976 if(IOchannel != NULL) fclose(IOchannel);
977 setupServer(1);
978 continue;
979 }
980
981 executeCommandLine(command, OUT_CONSOLE, &cmdStream);
982 }
983
984 #ifndef WINDOWS
985 return 0;
986 #endif
987 }
988 #endif /* not LIBRARY */
989
990 #ifdef READLINE
command_generator(char * text,int state)991 char * command_generator(char * text, int state)
992 {
993 static int list_index, len, clen;
994 char * name;
995
996 if (!state)
997 {
998 list_index = 0;
999 len = strlen (text);
1000 }
1001
1002 while((name = primitive[list_index].name))
1003 {
1004 list_index++;
1005
1006 if (strncmp (name, text, len) == 0)
1007 {
1008 clen = strlen(name) + 1;
1009 return(strncpy(malloc(clen), name, clen));
1010 }
1011 }
1012
1013 return ((char *)NULL);
1014 }
1015
1016 char ** completion_matches(const char * text, char * (*commands)(const char *, int));
1017
newlisp_completion(char * text,int start,int end)1018 char ** newlisp_completion (char * text, int start, int end)
1019 {
1020 return(completion_matches(text, (char * (*) (const char *, int) )command_generator));
1021 }
1022
1023 #endif /* READLINE */
1024
1025
getCommandLine(int batchMode,int * length)1026 char * getCommandLine(int batchMode, int * length)
1027 {
1028 char * cmd;
1029 int len;
1030
1031 #ifndef READLINE
1032 if(!batchMode) varPrintf(OUT_CONSOLE, "%s", prompt());
1033 cmd = calloc(MAX_COMMAND_LINE + 4, 1);
1034 if(fgets(cmd, MAX_COMMAND_LINE - 1, IOchannel) == NULL)
1035 {
1036 puts("");
1037 exit(0);
1038 }
1039 len = strlen(cmd);
1040 /* cut off line terminators left by fgets */
1041 *(cmd + len - LINE_FEED_LEN) = 0;
1042 len -= LINE_FEED_LEN; /* v.10.6.2 */
1043 #else /* READLINE */
1044 int errnoSave = errno;
1045 if((cmd = readline(batchMode ? "" : prompt())) == NULL)
1046 {
1047 puts("");
1048 exit(0);
1049 }
1050 errno = errnoSave; /* reset errno, set by readline() */
1051 len = strlen(cmd);
1052 if(len > 0)
1053 add_history(cmd);
1054 #endif
1055
1056 if(length != NULL) *length = len;
1057 return(cmd);
1058 }
1059
1060 #ifndef LIBRARY
1061
printHelpText(void)1062 void printHelpText(void)
1063 {
1064 varPrintf(OUT_CONSOLE, copyright,
1065 "usage: newlisp [file | url ...] [options ...] [file | url ...]\n\noptions:");
1066 varPrintf(OUT_CONSOLE,
1067 "%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n%s\n\n",
1068 " -h this help (no init.lsp)",
1069 " -n no init.lsp (must be first)",
1070 " -x <source> <target> link (no init.lsp)",
1071 " -v version",
1072 " -s <stacksize>",
1073 " -m <max-mem-MB> cell memory",
1074 " -e <quoted lisp expression>",
1075 " -l <path-file> log connections",
1076 " -L <path-file> log all",
1077 " -w <working dir>",
1078 " -c no prompts, net-eval, HTTP",
1079 " -C force prompts",
1080 " -t <usec-server-timeout>",
1081 " -p <port-no>",
1082 " -d <port-no> daemon mode",
1083 " -http only mode",
1084 " -http-safe safe mode",
1085 " -6 IPv6 mode",
1086 "\nmore info at http://newlisp.org");
1087 }
1088
setupServer(int reconnect)1089 void setupServer(int reconnect)
1090 {
1091 if((IOchannel = serverFD(IOport, IOdomain, reconnect)) == NULL)
1092 {
1093 printf("newLISP server setup on %s failed.\n", IOdomain);
1094 exit(1);
1095 }
1096
1097 #ifdef WINDOWS
1098 else IOchannelIsSocketStream = TRUE;
1099
1100 if(!IOchannelIsSocketStream)
1101 #endif
1102 setbuf(IOchannel,0);
1103
1104 if(!reconnect && !noPromptMode)
1105 varPrintf(OUT_CONSOLE, banner, OSTYPE, LIBFFI, ".");
1106 }
1107
1108 #endif /* ifndef LIBRARY */
1109
prompt(void)1110 char * prompt(void)
1111 {
1112 char * contextName = "";
1113 CELL * result;
1114 static char string[64];
1115
1116 if(evalSilent || noPromptMode)
1117 {
1118 evalSilent = 0;
1119 return("");
1120 }
1121
1122 if(promptEvent != nilSymbol)
1123 {
1124 if(executeSymbol(promptEvent, stuffSymbol(currentContext), &result) == CELL_STRING)
1125 {
1126 strncpy(string, (char *)result->contents, 64);
1127 string[63] = 0;
1128 deleteList(result);
1129 return(string);
1130 }
1131 deleteList(result);
1132 }
1133
1134 if(currentContext != mainContext)
1135 contextName = currentContext->name;
1136
1137 if(traceFlag & TRACE_SIGINT)
1138 {
1139 traceFlag &= ~TRACE_SIGINT;
1140 longjmp(errorJump, errorReg);
1141 }
1142
1143 if(traceFlag && !(traceFlag & TRACE_PRINT_EVAL))
1144 snprintf(string, 63, "%d %s> ", recursionCount, contextName);
1145 else
1146 snprintf(string, 63, "%s> ", contextName);
1147
1148 return(string);
1149 }
1150
1151
reset()1152 void reset()
1153 {
1154 recoverEnvironment(envStack);
1155
1156 while(resultStackIdx > resultStack)
1157 deleteList(popResult());
1158
1159 envStackIdx = envStack;
1160 lambdaStackIdx = lambdaStack;
1161
1162 freeCellBlocks();
1163
1164 if(printDevice) close((int)printDevice);
1165 printDevice = recursionCount = traceFlag = prettyPrintFlags = 0;
1166 evalFunc = NULL;
1167 #ifdef XML_SUPPORT
1168 xmlTags = NULL; /* force recreation */
1169 #endif
1170 pushResultFlag = TRUE;
1171 currentContext = mainContext;
1172 itSymbol->contents = (UINT)nilCell;
1173 }
1174
1175
recoverEnvironment(UINT * index)1176 void recoverEnvironment(UINT * index)
1177 {
1178 SYMBOL * symbol;
1179 CELL * cell;
1180
1181 while(envStackIdx > index)
1182 {
1183 symbol = (SYMBOL *)popEnvironment();
1184 cell = (CELL*)popEnvironment();
1185 if(cell != (CELL*)symbol->contents)
1186 {
1187 deleteList((CELL*)symbol->contents);
1188 symbol->contents = (UINT)cell;
1189 }
1190 }
1191 }
1192
1193
1194 char * processCommandEvent(char * command);
1195
executeCommandLine(char * command,UINT outDevice,STREAM * cmdStream)1196 void executeCommandLine(char * command, UINT outDevice, STREAM * cmdStream)
1197 {
1198 STREAM stream;
1199 char buff[MAX_COMMAND_LINE];
1200 char * cmd;
1201 int batchMode = 0;
1202 int len;
1203
1204 memset(buff + MAX_COMMAND_LINE -2, 0, 2);
1205
1206 if(memcmp(command, "[cmd]", 5) == 0)
1207 batchMode = 2;
1208 else if(isTTY && (*command == '\n' || *command == '\r' || *command == 0))
1209 batchMode = 1;
1210
1211 #ifndef LIBRARY
1212 if(!batchMode && commandEvent != nilSymbol)
1213 command = processCommandEvent(command);
1214 #endif
1215
1216 if(!isTTY && (*command == '\n' || *command == '\r' || *command == 0)) return;
1217
1218 if(!batchMode)
1219 {
1220 if(logTraffic == LOG_MORE)
1221 writeLog(command, TRUE);
1222 #ifndef LIBRARY
1223 if(strncmp(command, "GET /", 5) == 0)
1224 executeHTTPrequest(command + 5, HTTP_GET);
1225 else if(strncmp(command, "HEAD /", 6) == 0)
1226 executeHTTPrequest(command + 6, HTTP_HEAD);
1227 else if(strncmp(command, "PUT /", 5) == 0)
1228 executeHTTPrequest(command + 5, HTTP_PUT);
1229 else if(strncmp(command, "POST /", 6) == 0)
1230 executeHTTPrequest(command + 6, HTTP_POST);
1231 else if(strncmp(command, "DELETE /", 8) == 0)
1232 executeHTTPrequest(command + 8, HTTP_DELETE);
1233 #endif
1234 else if(!httpMode) goto EXEC_COMMANDLINE;
1235 return;
1236 }
1237
1238 if(httpMode) goto RETURN_BATCHMODE;
1239
1240 EXEC_COMMANDLINE:
1241 if(noPromptMode == FALSE && *command == '!' && *(command + 1) != ' ' && strlen(command) > 1)
1242 {
1243 if(system(command + 1)) return; /* avoid stupid compiler warning */
1244 return;
1245 }
1246
1247 if(cmdStream != NULL && batchMode)
1248 {
1249 openStrStream(cmdStream, 1024, TRUE);
1250 for(;;)
1251 {
1252 if(isTTY)
1253 {
1254 cmd = getCommandLine(TRUE, &len);
1255 if(len > (MAX_COMMAND_LINE - 3))
1256 len = MAX_COMMAND_LINE - 3;
1257 memcpy(buff, cmd, len);
1258 memcpy(buff + len, LINE_FEED, LINE_FEED_LEN);
1259 buff[len + LINE_FEED_LEN] = 0;
1260 free(cmd);
1261 }
1262 else
1263 if(fgets(buff, MAX_COMMAND_LINE - 1, IOchannel) == NULL) break;
1264 if( (memcmp(buff, "[/cmd]", 6) == 0 && batchMode == 2) ||
1265 (batchMode == 1 && (*buff == '\n' || *buff == '\r' || *buff == 0)))
1266 {
1267 if(logTraffic)
1268 writeLog(cmdStream->buffer, 0);
1269 makeStreamFromString(&stream, cmdStream->buffer);
1270 evaluateStream(&stream, outDevice, 0);
1271 return;
1272 }
1273 writeStreamStr(cmdStream, buff, 0);
1274 }
1275 closeStrStream(cmdStream);
1276 RETURN_BATCHMODE:
1277 if(!daemonMode) exit(1);
1278 if(IOchannel != NULL) fclose(IOchannel);
1279 #ifndef LIBRARY
1280 setupServer(1);
1281 #endif
1282 return;
1283 }
1284
1285 if(logTraffic == LOG_LESS) writeLog(command, TRUE);
1286 prettyPrintLength = 0;
1287
1288 makeStreamFromString(&stream, command);
1289 evaluateStream(&stream, outDevice, 0);
1290 }
1291
processCommandEvent(char * command)1292 char * processCommandEvent(char * command)
1293 {
1294 CELL * result;
1295
1296 if(executeSymbol(commandEvent, stuffString(command), &result) == CELL_STRING)
1297 {
1298 pushResult(result);
1299 command = (char *)result->contents;
1300 }
1301
1302 return(command);
1303 }
1304
1305 /*
1306 void printResultStack()
1307 {
1308 printf("result stack:\n");
1309 while(resultStackIdx > resultStack)
1310 {
1311 --resultStackIdx;
1312 printCell(*resultStackIdx, TRUE, OUT_CONSOLE);
1313 printf("\n");
1314 }
1315 printf("\n");
1316 }
1317 */
1318
1319 /* used for loadFile() and and executeCommandLine() */
evaluateStream(STREAM * stream,UINT outDevice,int flag)1320 CELL * evaluateStream(STREAM * stream, UINT outDevice, int flag)
1321 {
1322 CELL * program;
1323 CELL * eval = nilCell;
1324 CELL * xlate;
1325 UINT * resultIdxSave = resultStackIdx;
1326 int result = TRUE;
1327
1328 while(result)
1329 {
1330 pushResult(program = getCell(CELL_QUOTE));
1331 result = compileExpression(stream, program);
1332 if(readerEvent != nilSymbol && result)
1333 {
1334 --resultStackIdx; /* program cell consumed by executeSymbol() */
1335 executeSymbol(readerEvent, program, &xlate);
1336 pushResult(program = makeCell(CELL_QUOTE, (UINT)xlate));
1337 }
1338 if(result)
1339 {
1340 if(flag && eval != nilCell) deleteList(eval);
1341 eval = evaluateExpression((CELL *)program->contents);
1342 if(outDevice != 0 && !evalSilent)
1343 {
1344 printCell(eval, TRUE, outDevice);
1345 varPrintf(outDevice, "\n");
1346 if(logTraffic == LOG_MORE)
1347 {
1348 writeLog("-> ", 0);
1349 printCell(eval, TRUE, OUT_LOG);
1350 writeLog("", TRUE);
1351 }
1352 #ifdef EMSCRIPTEN
1353 if(outDevice) fflush(NULL);
1354 #endif
1355 }
1356 if(flag) eval = copyCell(eval);
1357 }
1358 cleanupResults(resultIdxSave);
1359 }
1360
1361 if(flag) return(eval);
1362 return(NULL);
1363 }
1364
1365
executeSymbol(SYMBOL * symbol,CELL * params,CELL ** result)1366 int executeSymbol(SYMBOL * symbol, CELL * params, CELL * * result)
1367 {
1368 CELL * program;
1369 CELL * cell;
1370 UINT * resultIdxSave = resultStackIdx;
1371
1372 if(symbol == nilSymbol || symbol == trueSymbol || symbol == NULL) return(0);
1373 pushResult(program = getCell(CELL_EXPRESSION));
1374 cell = makeCell(CELL_SYMBOL, (UINT)symbol);
1375 program->contents = (UINT)cell;
1376 if(params != NULL) cell->next = params;
1377
1378 if(result == NULL)
1379 {
1380 evaluateExpression(program);
1381 cleanupResults(resultIdxSave);
1382 return(0);
1383 }
1384
1385 *result = copyCell(evaluateExpression(program));
1386 cleanupResults(resultIdxSave);
1387
1388 return((*result)->type);
1389 }
1390
1391
1392 /* -------------------------- initialization -------------------- */
1393
initialize()1394 void initialize()
1395 {
1396 SYMBOL * symbol;
1397 CELL * pCell;
1398 char symName[8];
1399 int i;
1400
1401 /* build true and false cells */
1402 nilCell = getCell(CELL_NIL);
1403 nilCell->aux = nilCell->contents = (UINT)nilCell;
1404 nilCell->next = nilCell;
1405
1406 trueCell = getCell(CELL_TRUE);
1407 trueCell->contents = (UINT)trueCell;
1408
1409 /* make first symbol, which is context MAIN */
1410 currentContext = createRootContext("MAIN");
1411
1412 /* build symbols for primitives */
1413 for(i = 0; primitive[i].name != NULL; i++)
1414 {
1415 pCell = getCell(CELL_PRIMITIVE);
1416 symbol = translateCreateSymbol(
1417 primitive[i].name, CELL_PRIMITIVE, mainContext, TRUE);
1418 symbol->contents = (UINT)pCell;
1419 symbol->flags = primitive[i].flags | SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1420 pCell->contents = (UINT)primitive[i].function;
1421 pCell->aux = (UINT)symbol->name;
1422 }
1423
1424 /* build nil, true, * and ? symbols and others */
1425 nilSymbol = translateCreateSymbol("nil", CELL_NIL, mainContext, TRUE);
1426 nilSymbol->contents = (UINT)nilCell;
1427 trueSymbol = translateCreateSymbol("true", CELL_TRUE, mainContext, TRUE);
1428 trueSymbol->contents = (UINT)trueCell;
1429 starSymbol = translateCreateSymbol("*", CELL_PRIMITIVE, mainContext, TRUE);
1430 plusSymbol = translateCreateSymbol("+", CELL_PRIMITIVE, mainContext, TRUE);
1431 questionSymbol = translateCreateSymbol("?", CELL_NIL, mainContext, TRUE);
1432 atSymbol = translateCreateSymbol("@", CELL_NIL, mainContext, TRUE);
1433 argsSymbol = translateCreateSymbol("$args", CELL_NIL, mainContext, TRUE);
1434 mainArgsSymbol = translateCreateSymbol("$main-args", CELL_NIL, mainContext, TRUE);
1435 listIdxSymbol = translateCreateSymbol("$idx", CELL_NIL, mainContext, TRUE);
1436 itSymbol = translateCreateSymbol("$it", CELL_NIL, mainContext, TRUE);
1437 countSymbol = translateCreateSymbol("$count", CELL_NIL, mainContext, TRUE);
1438 sysxSymbol = translateCreateSymbol("$x", CELL_NIL, mainContext, TRUE);
1439 beginSymbol = translateCreateSymbol("begin", CELL_NIL, mainContext, TRUE);
1440 expandSymbol = translateCreateSymbol("expand", CELL_NIL, mainContext, TRUE);
1441
1442 symbol = translateCreateSymbol("ostype", CELL_STRING, mainContext, TRUE);
1443 symbol->flags = SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1444 symbol->contents = (UINT)stuffString(OSTYPE);
1445
1446 for(i = 0; i < MAX_REGEX_EXP; i++)
1447 {
1448 snprintf(symName, 8, "$%d", i);
1449 sysSymbol[i] = translateCreateSymbol(symName, CELL_NIL, mainContext, TRUE);
1450 sysSymbol[i]->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN;
1451 }
1452
1453 currentFunc = errorEvent = timerEvent = promptEvent = commandEvent = transferEvent = readerEvent = nilSymbol;
1454
1455 trueSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1456 nilSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1457 questionSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1458 atSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1459 argsSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1460 mainArgsSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1461 listIdxSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1462 itSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1463 countSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1464 sysxSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN;
1465
1466 countCell = stuffInteger(0);
1467 countSymbol->contents = (UINT)countCell ;
1468 argsSymbol->contents = (UINT)getCell(CELL_EXPRESSION);
1469 objSymbol.contents = (UINT)nilCell;
1470 objSymbol.context = mainContext;
1471 objCell = nilCell;
1472
1473 /* init signal handlers */
1474 for(i = 0; i < 32; i++)
1475 symHandler[i] = nilSymbol;
1476
1477 /* init system wide string streams */
1478 openStrStream(&readLineStream, 16, 0);
1479 openStrStream(&errorStream, MAX_LINE, 0);
1480 }
1481
initStacks()1482 void initStacks()
1483 {
1484 MAX_ENV_STACK = (MAX_CPU_STACK * 8 * 2);
1485 MAX_RESULT_STACK = (MAX_CPU_STACK * 2);
1486 if(envStack != NULL) freeMemory(envStack);
1487 if(resultStack != NULL) freeMemory(resultStack);
1488 if(lambdaStack != NULL) freeMemory(lambdaStack);
1489 envStackIdx = envStack = (UINT *)allocMemory((MAX_ENV_STACK + 16) * sizeof(UINT));
1490 envStackTop = envStack + MAX_ENV_STACK;
1491 resultStackIdx = resultStack = (UINT *)allocMemory((MAX_RESULT_STACK + 16) * sizeof(UINT));
1492 resultStackTop = resultStack + MAX_RESULT_STACK;
1493 lambdaStackIdx = lambdaStack = (UINT *)allocMemory((MAX_RESULT_STACK + 16) * sizeof(UINT));
1494 }
1495
1496
1497 /* ------------------------- evaluate s-expression --------------------- */
1498
1499
evaluateExpression(CELL * cell)1500 CELL * evaluateExpression(CELL * cell)
1501 {
1502 #ifdef ISO_C90
1503 CELL * result;
1504 UINT * resultIdxSave = resultStackIdx;
1505 CELL * args = NULL;
1506 CELL * pCell = NULL;
1507 SYMBOL * newContext = NULL;
1508 SYMBOL * sPtr = NULL;
1509 #endif
1510
1511 symbolCheck = NULL;
1512 stringCell = NULL;
1513
1514 if(isSelfEval(cell->type))
1515 return(cell);
1516
1517 if(cell->type == CELL_SYMBOL || cell->type == CELL_CONTEXT)
1518 {
1519 symbolCheck = (SYMBOL *)cell->contents;
1520 return((CELL *)symbolCheck->contents);
1521 }
1522
1523 #ifndef ISO_C90
1524 CELL * result;
1525 UINT * resultIdxSave = resultStackIdx;
1526 CELL * args = NULL;
1527 CELL * pCell = NULL;
1528 SYMBOL * newContext = NULL;
1529 SYMBOL * sPtr = NULL;
1530 #endif
1531
1532 switch(cell->type)
1533 {
1534 case CELL_QUOTE:
1535 return((CELL *)cell->contents);
1536
1537 case CELL_EXPRESSION:
1538 args = (CELL *)cell->contents;
1539 if(++recursionCount > (int)MAX_CPU_STACK)
1540 fatalError(ERR_OUT_OF_CALL_STACK, args, 0);
1541
1542 if(args->type == CELL_SYMBOL) /* precheck for speedup */
1543 {
1544 sPtr = (SYMBOL *)args->contents;
1545 newContext = sPtr->context;
1546 pCell = (CELL*)sPtr->contents;
1547 }
1548 else if(args->type == CELL_DYN_SYMBOL)
1549 {
1550 sPtr = getDynamicSymbol(args);
1551 newContext = sPtr->context;
1552 pCell = (CELL *)sPtr->contents;
1553 }
1554 else
1555 {
1556 pCell = evaluateExpression(args);
1557 newContext = currentContext;
1558 }
1559
1560 if(traceFlag) traceEntry(cell, pCell, args);
1561
1562 /* check for 'default' functor
1563 * allow function call with context name, i.e: (ctx)
1564 * assumes that a ctx:ctx contains a function
1565 */
1566 if(pCell->type == CELL_CONTEXT)
1567 {
1568 newContext = (SYMBOL *)pCell->contents;
1569 sPtr= translateCreateSymbol(newContext->name, CELL_NIL, newContext, TRUE);
1570 pCell = (CELL *)sPtr->contents;
1571
1572 /* if the default functor contains nil, it works like a hash function */
1573 if(isNil(pCell))
1574 {
1575 result = evaluateNamespaceHash(args->next, newContext);
1576 break;
1577 }
1578 }
1579
1580 /* pCell is evaluated op element */
1581 if(pCell->type == CELL_PRIMITIVE)
1582 {
1583 evalFunc = (CELL *(*)(CELL*))pCell->contents;
1584 result = evalFunc(args->next);
1585 evalFunc = NULL;
1586 break;
1587 }
1588
1589 if(pCell->type == CELL_LAMBDA)
1590 {
1591 pushLambda(cell);
1592 result = evaluateLambda((CELL *)pCell->contents, args->next, newContext);
1593 --lambdaStackIdx;
1594 break;
1595 }
1596
1597 if(pCell->type == CELL_FEXPR)
1598 {
1599 pushLambda(cell);
1600 result = evaluateLambdaMacro((CELL *)pCell->contents, args->next, newContext);
1601 --lambdaStackIdx;
1602 break;
1603 }
1604 #ifndef EMSCRIPTEN
1605 /* simple ffi with CDECL or DLL and extended libffi */
1606 if(pCell->type & IMPORT_MASK)
1607 {
1608 result = executeLibfunction(pCell, args->next);
1609 break;
1610 }
1611 #endif
1612 /* implicit indexing or resting for list, array or string
1613 */
1614 if(args->next != nilCell)
1615 {
1616 /* implicit indexing array */
1617 if(pCell->type == CELL_EXPRESSION)
1618 {
1619 if(!sPtr) sPtr = symbolCheck;
1620 result = implicitIndexList(pCell, args->next);
1621 symbolCheck = sPtr;
1622 pushResultFlag = FALSE;
1623 }
1624
1625 /* implicit indexing array */
1626 else if(pCell->type == CELL_ARRAY)
1627 {
1628 if(!sPtr) sPtr = symbolCheck;
1629 result = implicitIndexArray(pCell, args->next);
1630 symbolCheck = sPtr;
1631 pushResultFlag = FALSE;
1632 }
1633
1634 /* implicit indexing string */
1635 else if(pCell->type == CELL_STRING)
1636 {
1637 if(sPtr || (sPtr = symbolCheck))
1638 {
1639 result = implicitIndexString(pCell, args->next);
1640 /* result is always a copy */
1641 pushResult(result);
1642 symbolCheck = sPtr;
1643 --recursionCount;
1644 return(result);
1645 }
1646 else
1647 result = implicitIndexString(pCell, args->next);
1648 }
1649
1650 /* implicit resting for lists and strings */
1651 else if(isNumber(pCell->type))
1652 result = implicitNrestSlice(pCell, args->next);
1653
1654 else
1655 result = errorProcExt(ERR_INVALID_FUNCTION, cell);
1656 } /* implixit indexing, resting on lists and strings */
1657 else
1658 result = errorProcExt(ERR_INVALID_FUNCTION, cell);
1659 break;
1660
1661 case CELL_DYN_SYMBOL:
1662 symbolCheck = getDynamicSymbol(cell);
1663 return((CELL *)symbolCheck->contents);
1664
1665 default:
1666 result = nilCell;
1667 }
1668
1669 if(pushResultFlag)
1670 {
1671 if(resultStackIdx > resultStackTop)
1672 fatalError(ERR_OUT_OF_CALL_STACK, pCell, 0);
1673
1674 while(resultStackIdx > resultIdxSave)
1675 deleteList(popResult());
1676
1677 pushResult(result);
1678 }
1679 else
1680 pushResultFlag = TRUE;
1681
1682 if(traceFlag) traceExit(result, cell, pCell, args);
1683 --recursionCount;
1684 return(result);
1685 }
1686
1687
evaluateExpressionSafe(CELL * cell,int * errNo)1688 CELL * evaluateExpressionSafe(CELL * cell, int * errNo)
1689 {
1690 jmp_buf errorJumpSave;
1691 CELL * result;
1692
1693 memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
1694 if((*errNo = setjmp(errorJump)) != 0)
1695 {
1696 memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
1697 return(NULL);
1698 }
1699
1700 result = evaluateExpression(cell);
1701 memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
1702 return(result);
1703 }
1704
1705
evaluateNamespaceHash(CELL * args,SYMBOL * newContext)1706 CELL * evaluateNamespaceHash(CELL * args, SYMBOL * newContext)
1707 {
1708 SYMBOL * sPtr;
1709 CELL * pCell;
1710
1711 pCell = evaluateExpression(args);
1712 if(pCell->type == CELL_STRING || isNumber(pCell->type))
1713 {
1714 /* set contents */
1715 if(args->next != nilCell)
1716 {
1717 sPtr = makeSafeSymbol(pCell, newContext, TRUE);
1718
1719 itSymbol->contents = sPtr->contents;
1720 /* itSymbol may occur in evaluateExpression() */
1721 itSymbol->contents = (UINT)copyCell(evaluateExpression(args->next));
1722 deleteList((CELL *)sPtr->contents);
1723 sPtr->contents = itSymbol->contents;
1724 itSymbol->contents = (UINT)nilCell;
1725
1726 if(isNil((CELL *)sPtr->contents))
1727 {
1728 deleteAndFreeSymbol(sPtr, FALSE);
1729 return(nilCell);
1730 }
1731
1732 symbolCheck = sPtr;
1733 pushResultFlag = FALSE;
1734 return((CELL *)sPtr->contents);
1735 }
1736 /* get contents */
1737 else
1738 {
1739 sPtr = makeSafeSymbol(pCell, newContext, FALSE);
1740 if(sPtr == NULL)
1741 return(nilCell);
1742 else
1743 {
1744 symbolCheck = sPtr;
1745 pushResultFlag = FALSE;
1746 return((CELL *)sPtr->contents);
1747 }
1748 }
1749 }
1750 /* create Tree from association list */
1751 else if(pCell->type == CELL_EXPRESSION)
1752 {
1753 args = (CELL *)pCell->contents;
1754 while(args->type == CELL_EXPRESSION)
1755 {
1756 pCell = (CELL *)args->contents;
1757 if(pCell->type == CELL_STRING || isNumber(pCell->type))
1758 {
1759 sPtr = makeSafeSymbol(pCell, newContext, TRUE);
1760 deleteList((CELL *)sPtr->contents);
1761 sPtr->contents = (UINT)copyCell(pCell->next);
1762 }
1763 args = args->next;
1764 }
1765 return(stuffSymbol(newContext));
1766 }
1767 /* return association list */
1768 else if(pCell->type == CELL_NIL)
1769 return(associationsFromTree(newContext));
1770
1771 return(errorProcExt(ERR_INVALID_PARAMETER, pCell));
1772 }
1773
1774
1775 /* a symbol belonging to a dynamic context
1776 the parent context symbol points to the real context
1777 cell->contents -> name str of this symbol
1778 cell->aux -> symbol var which holds context (dynamic)
1779 ((SYMBOL*)cell->aux)->contents -> context cell
1780 */
getDynamicSymbol(CELL * cell)1781 SYMBOL * getDynamicSymbol(CELL * cell)
1782 {
1783 CELL * contextCell;
1784
1785 contextCell = (CELL *)((SYMBOL *)cell->aux)->contents;
1786 if(contextCell->type != CELL_CONTEXT)
1787 fatalError(ERR_CONTEXT_EXPECTED, stuffSymbol((SYMBOL*)cell->aux), TRUE);
1788
1789 return(translateCreateSymbol(
1790 (char*)cell->contents, /* name of dyn symbol */
1791 CELL_NIL,
1792 (SYMBOL*)contextCell->contents, /* contextPtr */
1793 TRUE));
1794 }
1795
1796
cleanupResults(UINT * from)1797 void cleanupResults(UINT * from)
1798 {
1799 while(resultStackIdx > from)
1800 deleteList(popResult());
1801 }
1802
1803 /* -------------------- evaluate lambda function ----------------------- */
1804
evaluateLambda(CELL * localLst,CELL * arg,SYMBOL * newContext)1805 CELL * evaluateLambda(CELL * localLst, CELL * arg, SYMBOL * newContext)
1806 {
1807 CELL * local;
1808 CELL * result = nilCell;
1809 CELL * cell;
1810 SYMBOL * symbol;
1811 SYMBOL * contextSave;
1812 UINT * resultIdxSave;
1813 int localCount = 1; /* 1 for $args */
1814
1815 if(envStackIdx > envStackTop)
1816 return(errorProc(ERR_OUT_OF_ENV_STACK));
1817
1818 if(localLst->type != CELL_EXPRESSION)
1819 return(errorProcExt(ERR_INVALID_LAMBDA, localLst));
1820
1821 /* evaluate arguments */
1822 if(arg != nilCell)
1823 {
1824 /* this symbol precheck does 10% speed improvement on lambdas */
1825 if(arg->type == CELL_SYMBOL)
1826 cell = result = copyCell((CELL*)((SYMBOL *)arg->contents)->contents);
1827 else
1828 cell = result = copyCell(evaluateExpression(arg));
1829
1830 while((arg = arg->next) != nilCell)
1831 {
1832 if(arg->type == CELL_SYMBOL)
1833 cell = cell->next = copyCell((CELL*)((SYMBOL *)arg->contents)->contents);
1834 else
1835 cell = cell->next = copyCell(evaluateExpression(arg));
1836 }
1837 }
1838
1839 /* change to new context */
1840 contextSave = currentContext;
1841 currentContext = newContext;
1842
1843 /* save environment and get parameters */
1844 local = (CELL*)localLst->contents;
1845 for(;;)
1846 {
1847 if(local->type == CELL_SYMBOL)
1848 symbol = (SYMBOL *)local->contents;
1849 /* get default parameters */
1850 else if(local->type == CELL_EXPRESSION)
1851 {
1852 cell = (CELL *)local->contents;
1853 if(cell->type == CELL_SYMBOL)
1854 {
1855 symbol = (SYMBOL *)cell->contents;
1856 if(result == nilCell)
1857 result = copyCell(evaluateExpression(cell->next));
1858 }
1859 else break;
1860 }
1861 else break;
1862
1863 if(isProtected(symbol->flags))
1864 return(errorProcExt(ERR_SYMBOL_PROTECTED, local));
1865
1866 /* save symbol environment */
1867 pushEnvironment(symbol->contents);
1868 pushEnvironment((UINT)symbol);
1869
1870 /* fill local symbols */
1871 if(result == nilCell) result = copyCell(nilCell);
1872 symbol->contents = (UINT)result;
1873
1874 cell = result;
1875 result = result->next;
1876
1877 /* unlink list */
1878 cell->next = nilCell;
1879
1880 local = local->next;
1881 localCount++;
1882 }
1883
1884 /* put unassigned args in protected $args */
1885 pushEnvironment(argsSymbol->contents);
1886 pushEnvironment((UINT)argsSymbol);
1887 argsSymbol->contents = (UINT)makeCell(CELL_EXPRESSION, (UINT)result);
1888
1889 /* get contents for (self), is nil if no ancestor caller is colon : */
1890 objSymbol.contents = (UINT)objCell;
1891
1892 #ifdef FOOP_DEBUG
1893 printf("objCell in lambda:");
1894 printCell(objCell, TRUE, OUT_CONSOLE);
1895 printf(" context:%s\n", currentContext->name);
1896 #endif
1897
1898 /* evaluate body expressions */
1899 resultIdxSave = resultStackIdx;
1900 result = nilCell;
1901 while( (localLst = localLst->next) != nilCell)
1902 {
1903 while(resultStackIdx > resultIdxSave)
1904 deleteList(popResult());
1905 result = evaluateExpression(localLst);
1906 }
1907 result = copyCell(result);
1908
1909 /* restore symbols used as locals */
1910 while(localCount--)
1911 {
1912 symbol = (SYMBOL *)popEnvironment();
1913 deleteList((CELL *)symbol->contents);
1914 symbol->contents = popEnvironment();
1915 }
1916
1917 currentContext = contextSave;
1918 symbolCheck = NULL;
1919 stringCell = NULL;
1920 return(result);
1921 }
1922
1923
evaluateLambdaMacro(CELL * localLst,CELL * arg,SYMBOL * newContext)1924 CELL * evaluateLambdaMacro(CELL * localLst, CELL * arg, SYMBOL * newContext)
1925 {
1926 CELL * local;
1927 CELL * result = nilCell;
1928 CELL * cell;
1929 SYMBOL * symbol;
1930 SYMBOL * contextSave;
1931 UINT * resultIdxSave;
1932 int localCount = 1; /* for $args */
1933
1934 if(envStackIdx > envStackTop)
1935 return(errorProc(ERR_OUT_OF_ENV_STACK));
1936
1937 if(localLst->type != CELL_EXPRESSION)
1938 return(errorProcExt(ERR_INVALID_MACRO, localLst));
1939
1940 local = (CELL *)localLst->contents;
1941
1942 contextSave = currentContext;
1943 currentContext = newContext;
1944
1945 /* save environment and get parameters */
1946 while (TRUE)
1947 {
1948 if(local->type == CELL_SYMBOL)
1949 symbol = (SYMBOL *)local->contents;
1950 /* get default parameters */
1951 else if(local->type == CELL_EXPRESSION)
1952 {
1953 if(((CELL*)local->contents)->type == CELL_SYMBOL)
1954 {
1955 cell = (CELL *)local->contents;
1956 if(cell->type == CELL_SYMBOL)
1957 {
1958 symbol = (SYMBOL *)cell->contents;
1959 if(arg == nilCell)
1960 arg = evaluateExpression(cell->next);
1961 }
1962 else break;
1963 }
1964 else break;
1965 }
1966 else break;
1967
1968 if(isProtected(symbol->flags))
1969 return(errorProcExt(ERR_SYMBOL_PROTECTED, local));
1970
1971 pushEnvironment(symbol->contents);
1972 pushEnvironment((UINT)symbol);
1973 symbol->contents = (UINT)copyCell(arg);
1974 local = local->next;
1975 arg = arg->next;
1976 localCount++;
1977 }
1978
1979 /* put unassigned args in $args */
1980 pushEnvironment(argsSymbol->contents);
1981 pushEnvironment((UINT)argsSymbol);
1982 argsSymbol->contents = (UINT)makeCell(CELL_EXPRESSION, (UINT)copyList(arg));
1983
1984 /* evaluate body expressions */
1985 resultIdxSave = resultStackIdx;
1986 while((localLst = localLst->next) != nilCell)
1987 {
1988 while(resultStackIdx > resultIdxSave)
1989 deleteList(popResult());
1990 result = evaluateExpression(localLst);
1991 }
1992 result = copyCell(result);
1993
1994 /* restore symbols used as locals */
1995 while(localCount--)
1996 {
1997 symbol = (SYMBOL *)popEnvironment();
1998 deleteList((CELL *)symbol->contents);
1999 symbol->contents = popEnvironment();
2000 }
2001
2002 currentContext = contextSave;
2003 symbolCheck = NULL;
2004 stringCell = NULL;
2005 return(result);
2006 }
2007
2008
2009 /* -------------- list/cell creation/deletion routines ---------------- */
2010
2011
stuffInteger(UINT contents)2012 CELL * stuffInteger(UINT contents)
2013 {
2014 CELL * cell;
2015
2016 if(firstFreeCell == NULL) allocBlock();
2017 cell = firstFreeCell;
2018 firstFreeCell = cell->next;
2019 ++cellCount;
2020
2021 cell->type = CELL_LONG;
2022 cell->next = nilCell;
2023 cell->aux = (UINT)nilCell;
2024 cell->contents = contents;
2025
2026 return(cell);
2027 }
2028
2029 #ifndef NEWLISP64
stuffInteger64(INT64 contents)2030 CELL * stuffInteger64(INT64 contents)
2031 {
2032 CELL * cell;
2033
2034 if(firstFreeCell == NULL) allocBlock();
2035 cell = firstFreeCell;
2036 firstFreeCell = cell->next;
2037 ++cellCount;
2038
2039 cell->type = CELL_INT64;
2040 cell->next = nilCell;
2041
2042 *(INT64 *)&cell->aux = contents;
2043 return(cell);
2044 }
2045 #endif
2046
stuffIntegerList(int argc,...)2047 CELL * stuffIntegerList(int argc, ...)
2048 {
2049 CELL * cell;
2050 CELL * list;
2051 va_list ap;
2052
2053 va_start(ap, argc);
2054
2055 list = makeCell(CELL_EXPRESSION, (UINT)stuffInteger(va_arg(ap, UINT)));
2056 cell = (CELL *)list->contents;
2057
2058 while(--argc)
2059 cell = cell->next = stuffInteger(va_arg(ap, UINT));
2060
2061 va_end(ap);
2062
2063 return(list);
2064 }
2065
2066 #ifdef BIGINT
stuffBigint(char * token)2067 CELL * stuffBigint(char * token)
2068 {
2069 int len;
2070 CELL * cell;
2071
2072 cell = getCell(CELL_BIGINT);
2073 cell->contents = (UINT)strToBigint(token, strlen(token), &len);
2074 cell->aux = len + 1;
2075
2076 return(cell);
2077 }
2078 #endif
2079
2080 /* only safe for text content */
stuffString(char * string)2081 CELL * stuffString(char * string)
2082 {
2083 CELL * cell;
2084
2085 cell = getCell(CELL_STRING);
2086 cell->aux = strlen(string) + 1;
2087 cell->contents = (UINT)allocMemory((UINT)cell->aux);
2088
2089 memcpy((void *)cell->contents, string, (UINT)cell->aux);
2090 return(cell);
2091 }
2092
2093 /* safe for binary content */
stuffStringN(char * string,int len)2094 CELL * stuffStringN(char * string, int len)
2095 {
2096 CELL * cell;
2097
2098 cell = getCell(CELL_STRING);
2099 cell->aux = len + 1;
2100 cell->contents = (UINT)allocMemory((UINT)cell->aux);
2101 memcpy((void *)cell->contents, string, len);
2102 *(char*)(cell->contents + len) = 0;
2103 return(cell);
2104 }
2105
stuffFloat(double floatVal)2106 CELL * stuffFloat(double floatVal)
2107 {
2108 CELL * cell;
2109
2110 cell = getCell(CELL_FLOAT);
2111 #ifndef NEWLISP64
2112 *(double *)&cell->aux = floatVal;
2113 #else
2114 *(double *)&cell->contents = floatVal;
2115 #endif
2116 return(cell);
2117 }
2118
stuffSymbol(SYMBOL * sPtr)2119 CELL * stuffSymbol(SYMBOL * sPtr)
2120 {
2121 CELL * cell;
2122
2123 cell = getCell(CELL_SYMBOL);
2124 cell->contents = (UINT)sPtr;
2125 return(cell);
2126 }
2127
2128 /* appends to a list, the list must have be either optimized
2129 with list->aux pointing to the last cell, or list->aux must
2130 contain nilCell and be empty
2131 */
2132
addList(CELL * list,CELL * new)2133 void addList(CELL * list, CELL * new)
2134 {
2135 if(list->aux == (UINT)nilCell)
2136 list->contents = (UINT)new;
2137 else
2138 ((CELL *)list->aux)->next = new;
2139 list->aux = (UINT)new;
2140 }
2141
convertNegativeOffset(ssize_t offset,CELL * list)2142 ssize_t convertNegativeOffset(ssize_t offset, CELL * list)
2143 {
2144 int len = 0;
2145
2146 while(list != nilCell)
2147 {
2148 ++len;
2149 list = list->next;
2150 }
2151 offset = len + offset;
2152 if(offset < 0)
2153 errorProc(ERR_LIST_INDEX_INVALID);
2154
2155 return(offset);
2156 }
2157
2158 /* ------------------------ creating and freeing cells ------------------- */
2159
getCell(int type)2160 CELL * getCell(int type)
2161 {
2162 CELL * cell;
2163
2164 if(firstFreeCell == NULL) allocBlock();
2165 cell = firstFreeCell;
2166 firstFreeCell = cell->next;
2167 ++cellCount;
2168
2169 cell->type = type;
2170 cell->next = nilCell;
2171 cell->aux = (UINT)nilCell;
2172 cell->contents = (UINT)nilCell;
2173
2174 return(cell);
2175 }
2176
2177
makeCell(int type,UINT contents)2178 CELL * makeCell(int type, UINT contents)
2179 {
2180 CELL * cell;
2181
2182 if(firstFreeCell == NULL) allocBlock();
2183 cell = firstFreeCell;
2184 firstFreeCell = cell->next;
2185 ++cellCount;
2186
2187 cell->type = type;
2188 cell->next = nilCell;
2189 cell->aux = (UINT)nilCell;
2190 cell->contents = contents;
2191
2192 return(cell);
2193 }
2194
2195
makeStringCell(char * contents,size_t size)2196 CELL * makeStringCell(char * contents, size_t size)
2197 {
2198 CELL * cell;
2199
2200 if(firstFreeCell == NULL) allocBlock();
2201 cell = firstFreeCell;
2202 firstFreeCell = cell->next;
2203 ++cellCount;
2204
2205 cell->type = CELL_STRING;
2206 cell->next = nilCell;
2207 cell->aux = (UINT)size + 1;
2208 cell->contents = (UINT)contents;
2209
2210 return(cell);
2211 }
2212
copyCell(CELL * cell)2213 CELL * copyCell(CELL * cell)
2214 {
2215 #ifdef ISO_C90
2216 CELL * newCell;
2217 CELL * list;
2218 UINT len;
2219 #endif
2220
2221 /* avoids copy if cell on resultStack */
2222 if(cell == (CELL *)*(resultStackIdx))
2223 {
2224 if(cell != nilCell && cell != trueCell)
2225 return(popResult());
2226 }
2227
2228 #ifndef ISO_C90
2229 CELL * newCell;
2230 CELL * list;
2231 UINT len;
2232 #endif
2233
2234 if(firstFreeCell == NULL) allocBlock();
2235 newCell = firstFreeCell;
2236 firstFreeCell = newCell->next;
2237 ++cellCount;
2238
2239 newCell->type = cell->type;
2240 newCell->next = nilCell;
2241 newCell->aux = cell->aux;
2242 newCell->contents = cell->contents;
2243
2244 if(isEnvelope(cell->type))
2245 {
2246 if(cell->type == CELL_ARRAY)
2247 newCell->contents = (UINT)copyArray(cell);
2248 else /* normal list expression */
2249 {
2250 if(cell->contents != (UINT)nilCell)
2251 {
2252 newCell->contents = (UINT)copyCell((CELL *)cell->contents);
2253 list = (CELL *)newCell->contents;
2254 cell = (CELL *)cell->contents;
2255 while((cell = cell->next) != nilCell)
2256 list = list->next = copyCell(cell);
2257 newCell->aux = (UINT)list; /* last element optimization */
2258 }
2259 }
2260 }
2261 else if(cell->type == CELL_STRING)
2262 {
2263 newCell->contents = (UINT)allocMemory((UINT)cell->aux);
2264 memcpy((void *)newCell->contents, (void*)cell->contents, (UINT)cell->aux);
2265 }
2266 else if(cell->type == CELL_DYN_SYMBOL)
2267 {
2268 len = strlen((char *)cell->contents);
2269 newCell->contents = (UINT)allocMemory(len + 1);
2270 memcpy((char *)newCell->contents, (char *)cell->contents, len + 1);
2271 }
2272 #ifdef BIGINT
2273 else if(cell->type == CELL_BIGINT)
2274 {
2275 newCell->contents = (UINT)allocMemory((UINT)cell->aux * sizeof(int));
2276 memcpy((void *)newCell->contents, (void*)cell->contents, (UINT)cell->aux * sizeof(int));
2277 }
2278 #endif
2279
2280 return(newCell);
2281 }
2282
2283
2284 /* this routine must be called with the list head
2285 if copying with envelope call copyCell() instead */
copyList(CELL * cell)2286 CELL * copyList(CELL * cell)
2287 {
2288 #ifdef ISO_C90
2289 CELL * firstCell;
2290 CELL * newCell;
2291 #endif
2292
2293 if(cell == nilCell)
2294 {
2295 lastCellCopied = nilCell;
2296 return(cell);
2297 }
2298
2299 #ifndef ISO_C90
2300 CELL * firstCell;
2301 CELL * newCell;
2302 #endif
2303
2304 firstCell = newCell = copyCell(cell);
2305
2306 while((cell = cell->next) != nilCell)
2307 newCell = newCell->next = copyCell(cell);
2308
2309 lastCellCopied = newCell;
2310 return(firstCell);
2311 }
2312
2313
2314 /* for deleting lists _and_ cells */
deleteList(CELL * cell)2315 void deleteList(CELL * cell)
2316 {
2317 CELL * next;
2318
2319 while(cell != nilCell)
2320 {
2321 if(isEnvelope(cell->type))
2322 {
2323 if(cell->type == CELL_ARRAY)
2324 deleteArray(cell);
2325 else
2326 deleteList((CELL *)cell->contents);
2327 }
2328
2329 else if(cell->type == CELL_STRING || cell->type == CELL_DYN_SYMBOL
2330 #ifdef BIGINT
2331 || cell->type == CELL_BIGINT
2332 #endif
2333 )
2334 freeMemory( (void *)cell->contents);
2335
2336 /* free cell changes in 10.6.3 */
2337 if(cell == nilCell || cell == trueCell)
2338 cell = cell->next;
2339 else
2340 {
2341 next = cell->next;
2342 cell->type = CELL_FREE;
2343 cell->next = firstFreeCell;
2344 firstFreeCell = cell;
2345 --cellCount;
2346 cell = next;
2347 }
2348
2349 }
2350 }
2351
2352 /* --------------- cell / memory allocation and deallocation -------------
2353
2354 allthough (MAC_BLOCK + 1) are allocated only MAX_BLOCK cells
2355 are used. The last cell only serves as a pointer to the next block
2356 */
2357
2358 CELL * cellMemory = NULL;/* start of cell memory */
2359 CELL * cellBlock = NULL; /* the last block allocated */
2360
allocBlock()2361 void allocBlock()
2362 {
2363 int i;
2364
2365 if(cellCount > MAX_CELL_COUNT - MAX_BLOCK)
2366 {
2367 printErrorMessage(ERR_NOT_ENOUGH_MEMORY, NULL, 0);
2368 exit(ERR_NOT_ENOUGH_MEMORY);
2369 }
2370
2371 if(cellMemory == NULL)
2372 {
2373 cellMemory = (CELL *)allocMemory((MAX_BLOCK + 1) * sizeof(CELL));
2374 cellBlock = cellMemory;
2375 }
2376 else
2377 {
2378 (cellBlock + MAX_BLOCK)->next =
2379 (CELL *)allocMemory((MAX_BLOCK + 1) * sizeof(CELL));
2380 cellBlock = (cellBlock + MAX_BLOCK)->next;
2381 }
2382
2383 for(i = 0; i < MAX_BLOCK; i++)
2384 {
2385 (cellBlock + i)->type = CELL_FREE;
2386 (cellBlock + i)->next = (cellBlock + i + 1);
2387 }
2388 (cellBlock + MAX_BLOCK - 1)->next = NULL;
2389 (cellBlock + MAX_BLOCK)->next = NULL;
2390 firstFreeCell = cellBlock;
2391 ++ blockCount;
2392 }
2393
2394
2395 /* Return unused blocks to OS, this is normally only called under error
2396 conditions but can also be forced issuing a (reset nil)
2397
2398 Older versions also did a complete cell mark and sweep. Now all
2399 error conditons clean out allocated cells and memory before doing
2400 the longjmp().
2401 */
2402
2403 /* not used, not tested
2404 void freeAllCells()
2405 {
2406 CELL * blockPtr = cellMemory;
2407 int i, j;
2408
2409 for(i = 0; i < blockCount; i++)
2410 {
2411 for(j = 0; j < MAX_BLOCK; j++)
2412 {
2413 if(*(UINT *)blockPtr != CELL_FREE)
2414 {
2415 deleteList(blockPtr);
2416 }
2417 blockPtr++;
2418 }
2419 blockPtr = blockPtr->next;
2420 }
2421 }
2422 */
2423
freeCellBlocks()2424 void freeCellBlocks()
2425 {
2426 CELL * blockPtr;
2427 CELL * lastBlockPtr = NULL;
2428 CELL * lastFreeCell = NULL;
2429 CELL * prevLastFreeCell;
2430 CELL * prevCellBlock;
2431 int i, freeCount;
2432
2433 cellBlock = blockPtr = cellMemory;
2434 firstFreeCell = NULL;
2435 while(blockPtr != NULL)
2436 {
2437 prevLastFreeCell = lastFreeCell;
2438 prevCellBlock = cellBlock;
2439 cellBlock = blockPtr;
2440 for(i = freeCount = 0; i < MAX_BLOCK; i++)
2441 {
2442 if(*(UINT *)blockPtr == CELL_FREE)
2443 {
2444 if(firstFreeCell == NULL)
2445 firstFreeCell = lastFreeCell = blockPtr;
2446 else
2447 {
2448 lastFreeCell->next = blockPtr;
2449 lastFreeCell = blockPtr;
2450 }
2451 freeCount++;
2452 }
2453 blockPtr++;
2454 }
2455 if(freeCount == MAX_BLOCK)
2456 {
2457 lastFreeCell = prevLastFreeCell;
2458 cellBlock = prevCellBlock;
2459 blockPtr = blockPtr->next;
2460 freeMemory(lastBlockPtr->next);
2461 --blockCount;
2462 lastBlockPtr->next = blockPtr;
2463 }
2464 else
2465 {
2466 lastBlockPtr = blockPtr;
2467 blockPtr = blockPtr->next;
2468 }
2469 }
2470 lastFreeCell->next = NULL;
2471 }
2472
2473
2474 /* OS memory allocation */
2475
allocMemory(size_t nbytes)2476 void * allocMemory(size_t nbytes)
2477 {
2478 void * ptr;
2479
2480 if( (ptr = (void *)malloc(nbytes)) == NULL)
2481 fatalError(ERR_NOT_ENOUGH_MEMORY, NULL, 0);
2482
2483 return(ptr);
2484 }
2485
callocMemory(size_t nbytes)2486 void * callocMemory(size_t nbytes)
2487 {
2488 void * ptr;
2489
2490 if( (ptr = (void *)calloc(nbytes, 1)) == NULL)
2491 fatalError(ERR_NOT_ENOUGH_MEMORY, NULL, 0);
2492
2493 return(ptr);
2494 }
2495
reallocMemory(void * prevPtr,UINT size)2496 void * reallocMemory(void * prevPtr, UINT size)
2497 {
2498 void * ptr;
2499
2500 if( (ptr = realloc(prevPtr, size)) == NULL)
2501 fatalError(ERR_NOT_ENOUGH_MEMORY, NULL, 0);
2502
2503 return(ptr);
2504 }
2505
2506 /* -------------------------- I/O routines ------------------------------ */
2507
2508 UINT printDevice;
2509 void prettyPrint(UINT device);
2510
varPrintf(UINT device,char * format,...)2511 void varPrintf(UINT device, char * format, ...)
2512 {
2513 char * buffer;
2514 va_list argptr;
2515
2516 va_start(argptr,format);
2517
2518 /* defined in nl-filesys.c if not in libc */
2519 vasprintf(&buffer, format, argptr);
2520
2521 prettyPrintLength += strlen(buffer);
2522 switch(device)
2523 {
2524 case OUT_NULL:
2525 return;
2526
2527 case OUT_DEVICE:
2528 if(printDevice != 0)
2529 {
2530 if(write(printDevice, buffer, strlen(buffer)) < 0)
2531 fatalError(ERR_IO_ERROR, 0, 0);
2532 break;
2533 }
2534 case OUT_CONSOLE:
2535 #ifdef LIBRARY
2536 if(!newlispLibConsoleFlag)
2537 {
2538 writeStreamStr(&libStrStream, buffer, 0);
2539 freeMemory(buffer);
2540 fflush(NULL);
2541 return;
2542 }
2543 else
2544 #endif
2545 if(IOchannel == stdin)
2546 {
2547 printf("%s", buffer);
2548 #if defined(MAC_OSX) || defined(_BSD) /* 10.7.3 */
2549 fflush(NULL);
2550 #else
2551 if(!isTTY) fflush(NULL);
2552 #endif
2553 }
2554 else if(IOchannel != NULL)
2555 fprintf(IOchannel, "%s", buffer);
2556 break;
2557 case OUT_LOG:
2558 writeLog(buffer, 0);
2559 break;
2560 default:
2561 writeStreamStr((STREAM *)device, buffer, 0);
2562 break;
2563 }
2564
2565 freeMemory(buffer);
2566
2567 va_end(argptr);
2568 }
2569
2570
printCell(CELL * cell,UINT printFlag,UINT device)2571 void printCell(CELL * cell, UINT printFlag, UINT device)
2572 {
2573 SYMBOL * sPtr;
2574 SYMBOL * sp;
2575 #ifdef BIGINT
2576 char * ptr;
2577 #endif
2578
2579 if(cell == debugPrintCell)
2580 varPrintf(device, "%s", debugPreStr);
2581
2582 switch(cell->type)
2583 {
2584 case CELL_NIL:
2585 varPrintf(device, "nil"); break;
2586
2587 case CELL_TRUE:
2588 varPrintf(device, "true"); break;
2589
2590 case CELL_LONG:
2591 varPrintf(device,"%"PRIdPTR, cell->contents); break;
2592 #ifndef NEWLISP64
2593 case CELL_INT64:
2594 varPrintf(device,"%"PRId64, *(INT64 *)&cell->aux); break;
2595 #endif /* NEWLISP64 */
2596 #ifdef BIGINT
2597 case CELL_BIGINT:
2598 ptr = bigintToDigits((int *)cell->contents, cell->aux - 1, 48, NULL);
2599 varPrintf(device, "%sL", ptr);
2600 free(ptr);
2601 break;
2602 #endif
2603 case CELL_FLOAT:
2604 #ifndef NEWLISP64
2605 varPrintf(device, prettyPrintFloat ,*(double *)&cell->aux);
2606 #else
2607 varPrintf(device, prettyPrintFloat ,*(double *)&cell->contents);
2608 #endif
2609 break;
2610
2611 case CELL_STRING:
2612 if(printFlag)
2613 printString((char *)cell->contents, device, cell->aux - 1);
2614 else
2615 varPrintf(device,"%s",cell->contents);
2616 break;
2617
2618 case CELL_SYMBOL:
2619 case CELL_CONTEXT:
2620 sPtr = (SYMBOL *)cell->contents;
2621 if(sPtr->context != currentContext
2622 /* if not global or global overwritten in current context */
2623 && (!(sPtr->flags & SYMBOL_GLOBAL) || (lookupSymbol(sPtr->name, currentContext)))
2624 && (symbolType(sPtr) != CELL_CONTEXT ||
2625 (SYMBOL *)((CELL*)sPtr->contents)->contents != sPtr)) /* context var */
2626 {
2627 varPrintf(device,"%s:%s", (char*)((SYMBOL*)sPtr->context)->name, sPtr->name);
2628 break;
2629 }
2630 /* overwriting global in MAIN */
2631 if(sPtr->context == currentContext
2632 && currentContext != mainContext
2633 && ((sp = lookupSymbol(sPtr->name, mainContext)) != NULL)
2634 && (sp->flags & SYMBOL_GLOBAL) )
2635 {
2636 varPrintf(device,"%s:%s", currentContext->name, sPtr->name);
2637 break;
2638 }
2639
2640 varPrintf(device,"%s",sPtr->name);
2641 break;
2642
2643 case CELL_PRIMITIVE:
2644 varPrintf(device,"%s@%lX", (char *)cell->aux, cell->contents);
2645 break;
2646 case CELL_IMPORT_CDECL:
2647 case CELL_IMPORT_FFI:
2648 #if defined(WINDOWS) || defined(CYGWIN)
2649 case CELL_IMPORT_DLL:
2650 #endif
2651
2652 #ifdef FFI
2653 if(cell->type == CELL_IMPORT_FFI)
2654 varPrintf(device,"%s@%lX", (char *)((FFIMPORT *)cell->aux)->name,
2655 cell->contents);
2656 else
2657 varPrintf(device,"%s@%lX", (char *)cell->aux, cell->contents);
2658 #else
2659 varPrintf(device,"%s@%lX", (char *)cell->aux, cell->contents);
2660 #endif
2661 break;
2662
2663 case CELL_QUOTE:
2664 varPrintf(device, "'");
2665 prettyPrintFlags |= PRETTYPRINT_DOUBLE;
2666 printCell((CELL *)cell->contents, printFlag, device);
2667 break;
2668
2669 case CELL_EXPRESSION:
2670 case CELL_LAMBDA:
2671 case CELL_FEXPR:
2672 printExpression(cell, device);
2673 break;
2674
2675 case CELL_DYN_SYMBOL:
2676 varPrintf(device, "%s:%s", ((SYMBOL*)cell->aux)->name, (char*)cell->contents);
2677 break;
2678 case CELL_ARRAY:
2679 printArray(cell, device);
2680 break;
2681
2682 default:
2683 varPrintf(device,"?");
2684 }
2685
2686 if(cell == debugPrintCell)
2687 varPrintf(device, "%s", debugPostStr);
2688
2689 prettyPrintFlags &= ~PRETTYPRINT_DOUBLE;
2690 }
2691
2692
printString(char * str,UINT device,int size)2693 void printString(char * str, UINT device, int size)
2694 {
2695 char chr;
2696
2697 if(size >= MAX_STRING)
2698 {
2699 varPrintf(device, "[text]");
2700 while(size--) varPrintf(device, "%c", *str++);
2701 varPrintf(device, "[/text]");
2702 return;
2703 }
2704
2705 varPrintf(device,"\"");
2706 while(size--)
2707 {
2708 switch(chr = *str++)
2709 {
2710 case '\b': varPrintf(device,"\\b"); break;
2711 case '\f': varPrintf(device,"\\f"); break;
2712 case '\n': varPrintf(device,"\\n"); break;
2713 case '\r': varPrintf(device,"\\r"); break;
2714 case '\t': varPrintf(device,"\\t"); break;
2715 case '\\': varPrintf(device,"\\\\"); break;
2716 case '"': varPrintf(device,"\\%c",'"'); break;
2717 default:
2718 if((unsigned char)chr < 32 || (stringOutputRaw && (unsigned char)chr > 126))
2719 varPrintf(device,"\\%03u", (unsigned char)chr);
2720 else
2721 varPrintf(device,"%c",chr); break;
2722 }
2723 }
2724 varPrintf(device,"\"");
2725 }
2726
2727
printExpression(CELL * cell,UINT device)2728 void printExpression(CELL * cell, UINT device)
2729 {
2730 CELL * item;
2731 int i, pFlags;
2732
2733 item = (CELL *)cell->contents;
2734
2735
2736 if(prettyPrintPars <= prettyPrintCurrent ||
2737 prettyPrintLength > prettyPrintMaxLength)
2738 prettyPrint(device);
2739
2740 if(cell->type == CELL_LAMBDA)
2741 {
2742 varPrintf(device, "(lambda ");
2743 ++prettyPrintPars;
2744 }
2745 else if(cell->type == CELL_FEXPR)
2746 {
2747 varPrintf(device, "(lambda-macro ");
2748 ++prettyPrintPars;
2749 }
2750 else
2751 {
2752 if(isSymbol(item->type))
2753 {
2754 if(item->type == CELL_SYMBOL)
2755 pFlags = ((SYMBOL *)item->contents)->flags;
2756 else
2757 pFlags = 0;
2758
2759 if((pFlags & PRINT_TYPE_MASK) != 0)
2760 {
2761 prettyPrint(device);
2762 varPrintf(device, "(");
2763 ++prettyPrintPars;
2764 for(i = 0; i < (pFlags & PRINT_TYPE_MASK); i++)
2765 {
2766 if(item == nilCell)
2767 {prettyPrintFlags |= PRETTYPRINT_DOUBLE; break;}
2768 printCell(item, TRUE, device);
2769 item = item->next;
2770 if(item != nilCell) varPrintf(device," ");
2771 else prettyPrintFlags |= PRETTYPRINT_DOUBLE;
2772 }
2773 prettyPrint(device);
2774 }
2775 else
2776 {
2777 varPrintf(device, "(");
2778 ++prettyPrintPars;
2779 }
2780 }
2781 else
2782 {
2783 varPrintf(device, "(");
2784 ++prettyPrintPars;
2785 }
2786 }
2787
2788
2789 while(item != nilCell)
2790 {
2791 if(prettyPrintLength > prettyPrintMaxLength) prettyPrint(device);
2792 printCell(item, TRUE, device);
2793 item = item->next;
2794 if(item != nilCell) varPrintf(device," ");
2795 }
2796
2797 varPrintf(device,")");
2798 --prettyPrintPars;
2799 }
2800
2801
prettyPrint(UINT device)2802 void prettyPrint(UINT device)
2803 {
2804 int i;
2805
2806 if(prettyPrintFlags) return;
2807
2808 if(prettyPrintPars > 0)
2809 varPrintf(device, LINE_FEED);
2810
2811 for(i = 0; i < prettyPrintPars; i++)
2812 varPrintf(device, "%s", prettyPrintTab);
2813
2814 prettyPrintLength = prettyPrintCurrent = prettyPrintPars;
2815 prettyPrintFlags |= PRETTYPRINT_DOUBLE;
2816 }
2817
2818
printSymbol(SYMBOL * sPtr,UINT device)2819 void printSymbol(SYMBOL * sPtr, UINT device)
2820 {
2821 CELL * cell;
2822 CELL * list = NULL;
2823 char * setStr;
2824 size_t offset, len;
2825
2826 prettyPrintCurrent = prettyPrintPars = 1;
2827 prettyPrintLength = 0;
2828 prettyPrintFlags &= ~PRETTYPRINT_DOUBLE;
2829
2830 if(sPtr->flags & SYMBOL_PROTECTED)
2831 setStr = "(constant ";
2832 else
2833 setStr = "(set ";
2834
2835 switch(symbolType(sPtr))
2836 {
2837 case CELL_PRIMITIVE:
2838 case CELL_IMPORT_CDECL:
2839 case CELL_IMPORT_FFI:
2840 #if defined(WINDOWS) || defined(CYGWIN)
2841 case CELL_IMPORT_DLL:
2842 #endif
2843 break;
2844 case CELL_SYMBOL:
2845 case CELL_DYN_SYMBOL:
2846 varPrintf(device, "%s", setStr);
2847 printSymbolNameExt(device, sPtr);
2848 varPrintf(device,"'");
2849 printCell((CELL *)sPtr->contents, TRUE, device);
2850 varPrintf(device, ")");
2851 break;
2852 case CELL_ARRAY:
2853 case CELL_EXPRESSION:
2854 varPrintf(device, "%s", setStr);
2855 printSymbolNameExt(device, sPtr);
2856 cell = (CELL *)sPtr->contents;
2857
2858 if(symbolType(sPtr) == CELL_ARRAY)
2859 {
2860 varPrintf(device, "(array ");
2861 printArrayDimensions(cell, device);
2862 varPrintf(device, "(flat ");
2863 list = cell = arrayList(cell, TRUE);
2864 }
2865
2866 cell = (CELL *)cell->contents;
2867
2868 varPrintf(device,"'(");
2869 prettyPrintPars = 2;
2870 if(cell->type == CELL_EXPRESSION) prettyPrint(device);
2871 while(cell != nilCell)
2872 {
2873 if(prettyPrintLength > prettyPrintMaxLength)
2874 prettyPrint(device);
2875 printCell(cell, TRUE, device);
2876 cell = cell->next;
2877 if(cell != nilCell) varPrintf(device, " ");
2878 }
2879 varPrintf(device, "))");
2880 if(symbolType(sPtr) == CELL_ARRAY)
2881 {
2882 deleteList(list);
2883 varPrintf(device ,"))");
2884 }
2885 break;
2886 case CELL_LAMBDA:
2887 case CELL_FEXPR:
2888 if(isProtected(sPtr->flags))
2889 {
2890 varPrintf(device, "%s%s%s", LINE_FEED, LINE_FEED, setStr);
2891 printSymbolNameExt(device, sPtr);
2892 printExpression((CELL *)sPtr->contents, device);
2893 varPrintf(device, ")");
2894 }
2895 else if (isGlobal(sPtr->flags))
2896 {
2897 printLambda(sPtr, device);
2898 varPrintf(device, "%s%s", LINE_FEED, LINE_FEED);
2899 printSymbolNameExt(device, sPtr);
2900 }
2901 else printLambda(sPtr, device);
2902 break;
2903 default:
2904 varPrintf(device, "%s", setStr);
2905 printSymbolNameExt(device, sPtr);
2906 cell = (CELL *)sPtr->contents;
2907 if(cell->type == CELL_STRING && cell->aux > MAX_STRING) /* size > 2047 */
2908 {
2909 varPrintf(device, "%s ", "(append ");
2910 offset = 0;
2911 while(offset < cell->aux - 1)
2912 {
2913 varPrintf(device, "%s ", LINE_FEED);
2914 len = (cell->aux - 1 - offset);
2915 len = len > 72 ? 72 : len;
2916 printString((char *)(cell->contents + offset), device, len);
2917 offset += len;
2918 }
2919 varPrintf(device, "))");
2920 break;
2921 }
2922 printCell(cell, TRUE, device);
2923 varPrintf(device, ")");
2924 break;
2925 }
2926
2927 varPrintf(device, "%s%s", LINE_FEED, LINE_FEED);
2928
2929 prettyPrintLength = prettyPrintPars = 0;
2930 }
2931
2932
printLambda(SYMBOL * sPtr,UINT device)2933 void printLambda(SYMBOL * sPtr, UINT device)
2934 {
2935 CELL * lambda;
2936 CELL * cell;
2937
2938 lambda = (CELL *)sPtr->contents;
2939 cell = (CELL *)lambda->contents;
2940 if(cell->type == CELL_EXPRESSION)
2941 cell = (CELL *)cell->contents;
2942
2943 if(!isLegalSymbol(sPtr->name))
2944 {
2945 varPrintf(device, "(set (sym ");
2946 printString(sPtr->name, device, strlen(sPtr->name));
2947 varPrintf(device, " %s) ", ((SYMBOL*)sPtr->context)->name);
2948 printExpression((CELL *)sPtr->contents, device);
2949 varPrintf(device, ")");
2950 return;
2951 }
2952
2953 if(symbolType(sPtr) == CELL_LAMBDA)
2954 varPrintf(device, "(define (");
2955 else
2956 varPrintf(device, "(define-macro (");
2957 prettyPrintPars += 2;
2958
2959 printSymbolName(device, sPtr);
2960 varPrintf(device, " ");
2961
2962 while(cell != nilCell)
2963 {
2964 printCell(cell, TRUE, device);
2965 cell = cell->next;
2966 if(cell != nilCell) varPrintf(device, " ");
2967 }
2968 varPrintf(device, ")");
2969 --prettyPrintPars;
2970 prettyPrint(device);
2971
2972 cell = (CELL *)lambda->contents;
2973 while((cell = cell->next) != nilCell)
2974 {
2975 if(prettyPrintLength > prettyPrintMaxLength) prettyPrint(device);
2976 printCell(cell, TRUE, device);
2977 if(!(cell->type & ENVELOPE_TYPE_MASK) && cell->next != nilCell) varPrintf(device, " ");
2978 }
2979
2980 varPrintf(device, ")");
2981 --prettyPrintPars;
2982 }
2983
2984
printSymbolName(UINT device,SYMBOL * sPtr)2985 void printSymbolName(UINT device, SYMBOL * sPtr)
2986 {
2987 SYMBOL * sp;
2988
2989 if(sPtr->context == currentContext)
2990 {
2991 if(*sPtr->name == *currentContext->name && strcmp(sPtr->name, currentContext->name) == 0)
2992 varPrintf(device, "%s:%s", sPtr->name, sPtr->name);
2993
2994 else if(currentContext != mainContext
2995 && ((sp = lookupSymbol(sPtr->name, mainContext)) != NULL)
2996 && (sp->flags & SYMBOL_GLOBAL) )
2997 varPrintf(device, "%s:%s", currentContext->name, sPtr->name);
2998 else
2999 varPrintf(device,"%s", sPtr->name);
3000 }
3001 else
3002 varPrintf(device,"%s:%s",
3003 (char *)((SYMBOL*)sPtr->context)->name, sPtr->name);
3004 }
3005
3006
printSymbolNameExt(UINT device,SYMBOL * sPtr)3007 void printSymbolNameExt(UINT device, SYMBOL * sPtr)
3008 {
3009 if(isGlobal(sPtr->flags))
3010 {
3011 varPrintf(device, "(global '");
3012 printSymbolName(device, sPtr);
3013 if(symbolType(sPtr) == CELL_LAMBDA || symbolType(sPtr) == CELL_FEXPR)
3014 varPrintf(device, ")");
3015 else varPrintf(device, ") ");
3016 }
3017 else
3018 {
3019 if(!isLegalSymbol(sPtr->name))
3020 {
3021 varPrintf(device, " (sym ");
3022 printString(sPtr->name, device, strlen(sPtr->name));
3023 varPrintf(device, " MAIN:%s) ", ((SYMBOL*)sPtr->context)->name);
3024 }
3025 else
3026 {
3027 varPrintf(device, "'");
3028 printSymbolName(device, sPtr);
3029 }
3030 varPrintf(device, " ");
3031 }
3032 }
3033
3034
p_prettyPrint(CELL * params)3035 CELL * p_prettyPrint(CELL * params)
3036 {
3037 CELL * result;
3038 char * str;
3039 size_t len;
3040
3041 if(params != nilCell)
3042 params = getInteger(params, &prettyPrintMaxLength);
3043 if(params != nilCell)
3044 {
3045 params = getStringSize(params, &str, &len, TRUE);
3046 prettyPrintTab = allocMemory(len + 1);
3047 memcpy(prettyPrintTab, str, len + 1);
3048 }
3049 if(params != nilCell)
3050 {
3051 getStringSize(params, &str, &len, TRUE);
3052 prettyPrintFloat = allocMemory(len + 1);
3053 memcpy(prettyPrintFloat, str, len + 1);
3054 }
3055
3056 result = getCell(CELL_EXPRESSION);
3057 addList(result, stuffInteger(prettyPrintMaxLength));
3058 addList(result, stuffString(prettyPrintTab));
3059 addList(result, stuffString(prettyPrintFloat));
3060
3061 return(result);
3062 }
3063
3064
3065
3066 /* -------------------------- error handling --------------------------- */
3067
3068 char * errorMessage[] =
3069 {
3070 "", /* 0 */
3071 "not enough memory", /* 1 */
3072 "environment stack overflow", /* 2 */
3073 "call or result stack overflow",/* 3 */
3074 "problem accessing file", /* 4 */
3075 "illegal token or expression", /* 5 */
3076 "missing parenthesis", /* 6 */
3077 "string token too long", /* 7 */
3078 "missing argument", /* 8 */
3079 "number or string expected", /* 9 */
3080 "value expected", /* 10 */
3081 "string expected", /* 11 */
3082 "symbol expected", /* 12 */
3083 "context expected", /* 13 */
3084 "symbol or context expected", /* 14 */
3085 "list expected", /* 15 */
3086 "list or array expected", /* 15 */
3087 "list or symbol expected", /* 17 */
3088 "list or string expected", /* 18 */
3089 "list or number expected", /* 19 */
3090 "array expected", /* 20 */
3091 "array, list or string expected", /* 21 */
3092 "lambda expected", /* 22 */
3093 "lambda-macro expected", /* 23 */
3094 "invalid function", /* 24 */
3095 "invalid lambda expression", /* 25 */
3096 "invalid macro expression", /* 26 */
3097 "invalid let parameter list", /* 27 */
3098 "problem saving file", /* 28 */
3099 "division by zero", /* 29 */
3100 "matrix expected", /* 30 */
3101 "wrong dimensions", /* 31 */
3102 "matrix is singular", /* 32 */
3103 "invalid option", /* 33 */
3104 "throw without catch", /* 34 */
3105 "problem loading library", /* 35 */
3106 "import function not found", /* 36 */
3107 "symbol is protected", /* 37 */
3108 "number out of range", /* 38 */
3109 "regular expression", /* 39 */
3110 "end of text [/text] tag", /* 40 */
3111 "mismatch in number of arguments", /* 41 */
3112 "problem in format string", /* 42 */
3113 "data type and format don't match", /* 43 */
3114 "invalid parameter", /* 44 */
3115 "invalid parameter: 0.0", /* 45 */
3116 "invalid parameter: NaN", /* 46 */
3117 "invalid UTF8 string", /* 47 */
3118 "illegal parameter type", /* 48 */
3119 "symbol not in MAIN context", /* 49 */
3120 "symbol not in current context", /* 50 */
3121 "target cannot be MAIN", /* 51 */
3122 "invalid list index", /* 52 */
3123 "array index out of bounds", /* 53 */
3124 "invalid string index", /* 54 */
3125 "nesting level to deep", /* 55 */
3126 "list reference changed", /* 56 */
3127 "invalid syntax", /* 57 */
3128 "user error", /* 58 */
3129 "user reset -", /* 59 */
3130 "received SIGINT -", /* 60 */
3131 "function is not reentrant", /* 61 */
3132 "not allowed on local symbol", /* 62 */
3133 "no reference found", /* 63 */
3134 "list is empty", /* 64 */
3135 "I/O error", /* 65 */
3136 "no working directory found", /* 66 */
3137 "invalid PID", /* 67 */
3138 "cannot open socket pair", /* 68 */
3139 "cannot fork process", /* 69 */
3140 "no comm channel found", /* 70 */
3141 "ffi preparation failed", /* 71 */
3142 "invalid ffi type", /* 72 */
3143 "ffi struct expected", /* 73 */
3144 "bigint type not applicable", /* 74 */
3145 "not a number or infinite", /* 75 */
3146 "cannot convert NULL to string",/* 76 */
3147 NULL
3148 };
3149
3150
errorMissingPar(STREAM * stream)3151 void errorMissingPar(STREAM * stream)
3152 {
3153 char str[48];
3154 snprintf(str, 40, "...%.40s", ((char *)((stream->ptr - stream->buffer) > 40 ? stream->ptr - 40 : stream->buffer)));
3155 errorProcExt2(ERR_MISSING_PAR, stuffString(str));
3156 }
3157
errorProcAll(int errorNumber,CELL * expr,int deleteFlag)3158 CELL * errorProcAll(int errorNumber, CELL * expr, int deleteFlag)
3159 {
3160 if(!traceFlag) fatalError(errorNumber, expr, deleteFlag);
3161 printErrorMessage(errorNumber, expr, deleteFlag);
3162 return(nilCell);
3163 }
3164
errorProc(int errorNumber)3165 CELL * errorProc(int errorNumber)
3166 {
3167 return(errorProcAll(errorNumber, NULL, 0));
3168 }
3169
3170 /* extended error info in expr */
errorProcExt(int errorNumber,CELL * expr)3171 CELL * errorProcExt(int errorNumber, CELL * expr)
3172 {
3173 return(errorProcAll(errorNumber, expr, 0));
3174 }
3175
3176 /* extended error info in expr, which has to be discarded after printing */
errorProcExt2(int errorNumber,CELL * expr)3177 CELL * errorProcExt2(int errorNumber, CELL * expr)
3178 {
3179 return(errorProcAll(errorNumber, expr, 1));
3180 }
3181
errorProcArgs(int errorNumber,CELL * expr)3182 CELL * errorProcArgs(int errorNumber, CELL * expr)
3183 {
3184 if(expr == nilCell)
3185 return(errorProcExt(ERR_MISSING_ARGUMENT, NULL));
3186
3187 return(errorProcExt(errorNumber, expr));
3188 }
3189
fatalError(int errorNumber,CELL * expr,int deleteFlag)3190 void fatalError(int errorNumber, CELL * expr, int deleteFlag)
3191 {
3192 printErrorMessage(errorNumber, expr, deleteFlag);
3193 #ifndef LIBRARY
3194 closeTrace();
3195 #endif
3196 longjmp(errorJump, errorReg);
3197 }
3198
printErrorMessage(UINT errorNumber,CELL * expr,int deleteFlag)3199 void printErrorMessage(UINT errorNumber, CELL * expr, int deleteFlag)
3200 {
3201 CELL * lambdaFunc;
3202 CELL * lambdaExpr;
3203 UINT * stackIdx = lambdaStackIdx;
3204 SYMBOL * context;
3205 int i;
3206
3207 if(errorNumber == EXCEPTION_THROW)
3208 errorNumber = ERR_THROW_WO_CATCH;
3209
3210 errorReg = errorNumber;
3211
3212 if(!errorNumber) return;
3213
3214 openStrStream(&errorStream, MAX_STRING, 1);
3215 writeStreamStr(&errorStream, "ERR: ", 5);
3216 writeStreamStr(&errorStream, errorMessage[errorReg], 0);
3217
3218 for(i = 0; primitive[i].name != NULL; i++)
3219 {
3220 if(evalFunc == primitive[i].function)
3221 {
3222 writeStreamStr(&errorStream, " in function ", 0);
3223 writeStreamStr(&errorStream, primitive[i].name, 0);
3224 break;
3225 }
3226 }
3227
3228 if(expr != NULL)
3229 {
3230 writeStreamStr(&errorStream, " : ", 3);
3231 printCell(expr, (errorNumber != ERR_USER_ERROR), (UINT)&errorStream);
3232 if(deleteFlag) deleteList(expr);
3233 }
3234
3235 while(stackIdx > lambdaStack)
3236 {
3237 lambdaExpr = (CELL *)*(--stackIdx);
3238 lambdaFunc = (CELL *)lambdaExpr->contents;
3239 if(lambdaFunc->type == CELL_SYMBOL)
3240 {
3241 writeStreamStr(&errorStream, LINE_FEED, 0);
3242 writeStreamStr(&errorStream, "called from user function ", 0);
3243 context = ((SYMBOL *)lambdaFunc->contents)->context;
3244 if(context != mainContext)
3245 {
3246 writeStreamStr(&errorStream, context->name, 0);
3247 writeStreamStr(&errorStream, ":", 0);
3248 }
3249 /* writeStreamStr(&errorStream, ((SYMBOL *)lambdaFunc->contents)->name, 0); */
3250 printCell(lambdaExpr, (errorNumber != ERR_USER_ERROR), (UINT)&errorStream); /* 10.6.3 */
3251 }
3252 }
3253
3254 if(!(traceFlag & TRACE_SIGINT)) evalFunc = NULL;
3255 parStackCounter = prettyPrintPars = 0;
3256
3257 if(evalCatchFlag && !((traceFlag & TRACE_SIGINT)
3258 || (traceFlag & TRACE_IN_DEBUG))) return;
3259
3260 if(errorEvent == nilSymbol)
3261 {
3262 if(errorNumber == ERR_SIGINT)
3263 printf("%s", errorStream.buffer);
3264 else
3265 {
3266 varPrintf(OUT_CONSOLE, "\n%.1024s\n", errorStream.buffer);
3267 if(logTraffic == LOG_MORE) writeLog(errorStream.buffer, TRUE);
3268 }
3269 }
3270
3271 if(traceFlag & TRACE_PRINT_EVAL) tracePrint(errorStream.buffer, NULL);
3272 }
3273
3274
3275 extern UINT * lambdaStack;
3276 extern UINT * lambdaStackIdx;
p_history(CELL * params)3277 CELL * p_history(CELL * params)
3278 {
3279 CELL * history;
3280 CELL * lambdaFunc;
3281 CELL * lambdaExpr;
3282 UINT * stackIdx = lambdaStackIdx;
3283
3284 history = getCell(CELL_EXPRESSION);
3285 while(stackIdx > lambdaStack)
3286 {
3287 lambdaExpr = (CELL *)*(--stackIdx);
3288 lambdaFunc = (CELL *)lambdaExpr->contents;
3289 if(lambdaFunc->type == CELL_SYMBOL)
3290 {
3291 if(getFlag(params))
3292 addList(history, copyCell(lambdaExpr));
3293 else
3294 addList(history, copyCell((CELL*)lambdaExpr->contents));
3295 }
3296 }
3297
3298 return(history);
3299 }
3300
3301
3302 /* --------------------------- load source file ------------------------- */
3303
3304
loadFile(char * fileName,UINT offset,int linkFlag,SYMBOL * context)3305 CELL * loadFile(char * fileName, UINT offset, int linkFlag, SYMBOL * context)
3306 {
3307 CELL * result;
3308 STREAM stream;
3309 int errNo, sourceLen;
3310 jmp_buf errorJumpSave;
3311 SYMBOL * contextSave;
3312 #ifdef LOAD_DEBUG
3313 int i;
3314 #endif
3315
3316 contextSave = currentContext;
3317 currentContext = context;
3318 if(linkFlag)
3319 sourceLen = *((int *) (linkOffset + 4));
3320 else sourceLen = MAX_FILE_BUFFER;
3321
3322 #ifndef EMSCRIPTEN
3323 if(my_strnicmp(fileName, "http://", 7) == 0)
3324 {
3325 result = getPutPostDeleteUrl(fileName, nilCell, HTTP_GET, CONNECT_TIMEOUT);
3326 pushResult(result);
3327 if(memcmp((char *)result->contents, "ERR:", 4) == 0)
3328 return(errorProcExt2(ERR_ACCESSING_FILE, stuffString((char *)result->contents)));
3329 result = copyCell(sysEvalString((char *)result->contents, context, nilCell, EVAL_STRING));
3330 currentContext = contextSave;
3331 return(result);
3332 }
3333 #endif
3334
3335 if(makeStreamFromFile(&stream, fileName, sourceLen + 4 * MAX_STRING, offset) == 0)
3336 return(NULL);
3337
3338 memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
3339 if((errNo = setjmp(errorJump)) != 0)
3340 {
3341 closeStrStream(&stream);
3342 memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
3343 currentContext = contextSave;
3344 longjmp(errorJump, errNo);
3345 }
3346
3347 #ifdef LOAD_DEBUG
3348 for(i = 0; i<recursionCount; i++) printf(" ");
3349 printf("load: %s\n", fileName);
3350 #endif
3351
3352 result = evaluateStream(&stream, 0, TRUE);
3353 currentContext = contextSave;
3354
3355 #ifdef LOAD_DEBUG
3356 for(i = 0; i<recursionCount; i++) printf(" ");
3357 printf("finish load: %s\n", fileName);
3358 #endif
3359
3360 memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
3361 closeStrStream(&stream);
3362 return(result);
3363 }
3364
3365
linkSource(char * pathname,char * source,char * target)3366 void linkSource(char * pathname, char * source, char * target)
3367 {
3368 int sourceLen;
3369 char * buffer;
3370 int size, offset = 0;
3371 char * ptr;
3372
3373 #ifdef WINDOWS
3374 /* gets full path of currently executing newlisp.exe */
3375 pathname = win_getExePath(alloca(PATH_MAX));
3376 #else /* Unix */
3377 if(strchr(pathname, '/') == NULL)
3378 pathname = which(pathname, alloca(PATH_MAX));
3379 #endif
3380
3381 size = readFile(pathname, &buffer);
3382 sourceLen = (size_t)fileSize(source);
3383
3384 if(errno)
3385 {
3386 printf("%s\n", strerror(errno));
3387 exit(errno);
3388 }
3389
3390 ptr = buffer;
3391
3392 if(strncmp(linkOffset + 4, "@@@@", 4) != 0) return; /* already linked */
3393 do {
3394 offset = searchBuffer(ptr, size - (ptr - buffer) , "@@@@", 4, 1);
3395 ptr = ptr + offset + 4;
3396 } while (strncmp(ptr - 8, "&&&&", 4) != 0); /* the linkOffset */
3397
3398 offset = (ptr - buffer - 8);
3399 *(int *)(buffer + offset) = (int)size;
3400 *(int *)(buffer + offset + 4) = (int)sourceLen;
3401 writeFile(target, buffer, size, "w");
3402 readFile(source, &buffer);
3403 writeFile(target, buffer, sourceLen, "a");
3404
3405 free(buffer);
3406 }
3407
3408 /* -------------------------- parse / compile -----------------------------
3409
3410 Takes source in a string stream and and envelope cell and compiles
3411 newLISP source into an internal LISP cell structure tree. The tree
3412 can be decompiled to source at any time and is processed by the
3413 evaluateExpression() function.
3414
3415 */
3416 int references(SYMBOL *, int);
compileExpression(STREAM * stream,CELL * cell)3417 int compileExpression(STREAM * stream, CELL * cell)
3418 {
3419 char token[MAX_STRING + 4];
3420 double floatNumber;
3421 CELL * newCell;
3422 CELL * contextCell;
3423 CELL * preCell;
3424 SYMBOL * contextPtr;
3425 SYMBOL * sPtr;
3426 int listFlag, tklen;
3427 char * lastPtr;
3428 int errnoSave;
3429 INT64 number;
3430
3431 listFlag = TRUE; /* cell is either quote or list envelope */
3432
3433 GETNEXT:
3434 lastPtr = stream->ptr;
3435 switch(getToken(stream, token, &tklen))
3436 {
3437 case TKN_ERROR:
3438 errorProcExt2(ERR_EXPRESSION, stuffStringN(lastPtr,
3439 (strlen(lastPtr) < 60) ? strlen(lastPtr) : 60));
3440 return(FALSE);
3441
3442 case TKN_EMPTY:
3443 if(parStackCounter != 0) errorMissingPar(stream);
3444 return(FALSE);
3445
3446 case TKN_CHARACTER:
3447 newCell = stuffInteger((UINT)token[0]);
3448 break;
3449
3450 case TKN_HEX:
3451 newCell = stuffInteger64((INT64)strtoull(token,NULL,0));
3452 break;
3453
3454 case TKN_BINARY:
3455 newCell = stuffInteger64((INT64)strtoull(&token[2],NULL,2));
3456 break;
3457
3458 case TKN_OCTAL:
3459 newCell = stuffInteger64(strtoll(token,NULL,0));
3460 break;
3461
3462 case TKN_DECIMAL:
3463 errnoSave = errno;
3464 errno = 0;
3465 #ifdef BIGINT
3466 if(*(token + tklen - 1) == 'L')
3467 {
3468 newCell = stuffBigint(token);
3469 break;
3470 }
3471 #endif
3472
3473 #ifndef NEWLISP64
3474 number = (INT64)strtoll(token, NULL, 0);
3475 #else
3476 number = strtoll(token, NULL, 0);
3477 #endif
3478
3479 #ifdef BIGINT
3480 if(errno == ERANGE)
3481 {
3482 newCell = stuffBigint(token);
3483 errno = errnoSave;
3484 break;
3485 }
3486 #endif
3487
3488 newCell = stuffInteger64(number);
3489 errno = errnoSave;
3490 break;
3491
3492 case TKN_FLOAT:
3493 floatNumber = (double)atof(token);
3494 newCell = stuffFloat(floatNumber);
3495 break;
3496
3497 case TKN_STRING:
3498 newCell = stuffStringN(token, tklen);
3499 break;
3500
3501 case TKN_SYMBOL:
3502 if(strcmp(token, "lambda") == 0 || strcmp(token, "fn") == 0)
3503 {
3504 if(cell->type != CELL_EXPRESSION)
3505 {
3506 errorProcExt2(ERR_INVALID_LAMBDA, stuffString(lastPtr));
3507 return(FALSE);
3508 }
3509 cell->type = CELL_LAMBDA;
3510 cell->aux = (UINT)nilCell;
3511 goto GETNEXT;
3512 }
3513 else if(strcmp(token, "lambda-macro") == 0 || strcmp(token, "fn-macro") == 0)
3514 {
3515 if(cell->type != CELL_EXPRESSION)
3516 {
3517 errorProcExt2(ERR_INVALID_LAMBDA, stuffString(lastPtr));
3518 return(FALSE);
3519 }
3520 cell->type = CELL_FEXPR;
3521 cell->aux = (UINT)nilCell;
3522 goto GETNEXT;
3523 }
3524 else if(strncmp(token, "[text]", 6) == 0)
3525 {
3526 newCell = makeCell(CELL_STRING, (UINT)readStreamText(stream, &tklen));
3527 if(newCell->contents == 0)
3528 {
3529 deleteList(newCell);
3530 errorProc(ERR_TEXT_END_TAG);
3531 }
3532 newCell->aux = tklen + 1;
3533 break;
3534 }
3535 newCell = getCell(CELL_SYMBOL);
3536 if(*token == '$')
3537 {
3538 newCell->contents = (UINT)translateCreateSymbol(
3539 token, CELL_NIL, mainContext, TRUE);
3540 ((SYMBOL *)newCell->contents)->flags |= SYMBOL_GLOBAL;
3541 }
3542 else
3543 newCell->contents = (UINT)translateCreateSymbol(
3544 token, CELL_NIL, currentContext, 0);
3545 break;
3546
3547 case TKN_CONTEXT:
3548 contextPtr = NULL;
3549 if(currentContext != mainContext)
3550 {
3551 if(strcmp(currentContext->name, token) == 0)
3552 contextPtr = currentContext;
3553 else
3554 contextPtr = lookupSymbol(token, currentContext);
3555 }
3556
3557 if(contextPtr == NULL)
3558 {
3559 contextPtr = translateCreateSymbol(
3560 token, CELL_CONTEXT, mainContext, TRUE);
3561 }
3562
3563 contextCell = (CELL *)contextPtr->contents;
3564 if(getToken(stream, token, &tklen) != TKN_SYMBOL)
3565 errorProcExt2(ERR_SYMBOL_EXPECTED, stuffString(lastPtr));
3566
3567 /* context does not exist */
3568 if(contextCell->type != CELL_CONTEXT
3569 || contextPtr != (SYMBOL*)contextCell->contents)
3570 {
3571 newCell = getCell(CELL_DYN_SYMBOL);
3572 newCell->aux = (UINT)contextPtr;
3573 newCell->contents = (UINT)allocMemory(tklen + 1);
3574 strncpy((char *)newCell->contents, token, tklen + 1);
3575 break;
3576 }
3577
3578 /* context exists make a symbol for it */
3579 newCell = getCell(CELL_SYMBOL);
3580 newCell->contents = (UINT)translateCreateSymbol(
3581 token, CELL_NIL, contextPtr, TRUE);
3582 break;
3583
3584 case TKN_QUOTE:
3585 newCell = getCell(CELL_QUOTE);
3586 compileExpression(stream, newCell);
3587 break;
3588
3589 case TKN_LEFT_PAR:
3590 ++parStackCounter;
3591 newCell = getCell(CELL_EXPRESSION);
3592 compileExpression(stream, newCell);
3593 if(((CELL *)newCell->contents)->type == CELL_SYMBOL)
3594 {
3595 sPtr = (SYMBOL *)((CELL *)newCell->contents)->contents;
3596 /* macro expansion */
3597 if(sPtr->flags & SYMBOL_MACRO)
3598 {
3599 preCell = copyCell(evaluateExpression(newCell));
3600 deleteList(newCell);
3601 newCell = preCell;
3602 }
3603 }
3604 break;
3605
3606 case TKN_RIGHT_PAR:
3607 if(parStackCounter == 0) errorMissingPar(stream);
3608 --parStackCounter;
3609 cell->next = nilCell;
3610 return(TRUE);
3611
3612 default:
3613 errorProcExt2(ERR_EXPRESSION, stuffString(lastPtr));
3614 return(FALSE);
3615
3616 }
3617
3618 linkCell(cell, newCell, listFlag);
3619
3620 if(cell->type == CELL_QUOTE && listFlag == TRUE)
3621 return(TRUE);
3622
3623 listFlag = FALSE;
3624 cell = newCell;
3625
3626 if(parStackCounter != 0)
3627 {
3628 if(*(stream->ptr) != 0) goto GETNEXT;
3629 else errorMissingPar(stream);
3630 }
3631
3632 return(FALSE);
3633 }
3634
3635
linkCell(CELL * left,CELL * right,int linkFlag)3636 void linkCell(CELL * left, CELL * right, int linkFlag)
3637 {
3638 if(linkFlag == 0) left->next = right;
3639 else left->contents = (UINT)right;
3640 }
3641
getToken(STREAM * stream,char * token,int * ptr_len)3642 int getToken(STREAM * stream, char * token, int * ptr_len)
3643 {
3644 char *tkn;
3645 char chr;
3646 int tknLen;
3647 #ifdef SUPPORT_UTF8
3648 int len;
3649 #endif
3650 int floatFlag;
3651 int bracketBalance;
3652 char buff[8];
3653
3654 tkn = token;
3655 tknLen = floatFlag = 0;
3656 *tkn = 0;
3657
3658 STRIP:
3659 if(stream->ptr > (stream->buffer + stream->size - 4 * MAX_STRING))
3660 {
3661 if(stream->handle == 0)
3662 {
3663 /* coming from commmand line or p_evalString */
3664 stream->buffer = stream->ptr;
3665 }
3666 else
3667 {
3668 stream->position += (stream->ptr - stream->buffer);
3669 lseek((int)stream->handle, stream->position, SEEK_SET);
3670 memset(stream->buffer, 0, stream->size + 1);
3671
3672 if(read(stream->handle, stream->buffer, stream->size) > 0)
3673 stream->ptr = stream->buffer;
3674 else
3675 {
3676 *stream->ptr = 0;
3677 return(TKN_EMPTY);
3678 }
3679 }
3680 }
3681
3682 while((unsigned char)*stream->ptr <= ' ' && (unsigned char)*stream->ptr != 0)
3683 ++stream->ptr;
3684
3685 if(*stream->ptr == 0) return(TKN_EMPTY);
3686
3687 /* check for comments */
3688 if(*stream->ptr == ';' || *stream->ptr == '#')
3689 {
3690 stream->ptr++;
3691 for(;;)
3692 {
3693 if(*stream->ptr == 0) return(TKN_EMPTY);
3694 if(*stream->ptr == '\n' || *stream->ptr == '\r')
3695 break;
3696 stream->ptr++;
3697 }
3698 stream->ptr++;
3699 goto STRIP;
3700 }
3701
3702
3703 if( *stream->ptr == '-' || *stream->ptr == '+')
3704 {
3705 if(isDigit((unsigned char)*(stream->ptr + 1))
3706 || *(stream->ptr + 1) == lc_decimal_point ) /* added 10.4.8 to allow -.9 */
3707 *(tkn++) = *(stream->ptr++), tknLen++;
3708 }
3709
3710
3711 if(isDigit((unsigned char)*stream->ptr) ||
3712 (*stream->ptr == lc_decimal_point &&
3713 isDigit((unsigned char)*(stream->ptr + 1))))
3714 {
3715 if(*stream->ptr == '0' && isDigit((unsigned char)*(stream->ptr + 1)))
3716 {
3717 *(tkn++) = *(stream->ptr++), tknLen++;
3718 while(*stream->ptr < '8' && *stream->ptr >= '0' && *stream->ptr != 0)
3719 *(tkn++) = *(stream->ptr++), tknLen++;
3720 *tkn = 0;
3721 return(TKN_OCTAL);
3722 }
3723
3724 while(isDigit((unsigned char)*stream->ptr) && tknLen < MAX_DIGITS)
3725 *(tkn++) = *(stream->ptr++), tknLen++;
3726
3727 if(toupper(*stream->ptr) == 'X' && token[0] == '0')
3728 {
3729 *(tkn++) = *(stream->ptr++), tknLen++;
3730 while(isxdigit((unsigned char)*stream->ptr) && tknLen < MAX_HEX_NO)
3731 *(tkn++) = *(stream->ptr++), tknLen++;
3732 *tkn = 0;
3733 return(TKN_HEX);
3734 }
3735
3736 if(toupper(*stream->ptr) == 'B' && token[0] == '0')
3737 {
3738 *(tkn++) = *(stream->ptr++), tknLen++;
3739 while((*stream->ptr == '0' || *stream->ptr == '1') && tknLen < MAX_BIN_NO)
3740 *(tkn++) = *(stream->ptr++), tknLen++;
3741 *tkn = 0;
3742 return(TKN_BINARY);
3743 }
3744
3745 if(*stream->ptr == lc_decimal_point)
3746 {
3747 *(tkn++) = *(stream->ptr++), tknLen++;
3748 while(isDigit((unsigned char)*stream->ptr) && tknLen < MAX_DECIMALS)
3749 *(tkn++) = *(stream->ptr++), tknLen++;
3750 floatFlag = TRUE;
3751 }
3752 else if(toupper(*stream->ptr) != 'E')
3753 {
3754 if(*stream->ptr == 'L') *(tkn++) = *(stream->ptr++), tknLen++;
3755 *tkn = 0;
3756 *ptr_len = tknLen;
3757 return(TKN_DECIMAL);
3758 }
3759
3760 if(toupper(*stream->ptr) == 'E')
3761 {
3762 if(isDigit((unsigned char)*(stream->ptr+2))
3763 && ( *(stream->ptr+1) == '-' || *(stream->ptr+1) == '+') )
3764 *(tkn++) = *(stream->ptr++), tknLen++;
3765 if(isDigit((unsigned char)*(stream->ptr+1)))
3766 {
3767 *(tkn++) = *(stream->ptr++), tknLen++;
3768 while(isDigit((unsigned char)*stream->ptr) && tknLen < MAX_SYMBOL)
3769 *(tkn++) = *(stream->ptr++), tknLen++;
3770 }
3771 else
3772 {
3773 *tkn = 0;
3774 if(floatFlag == TRUE) return(TKN_FLOAT);
3775 else
3776 {
3777 *ptr_len = tknLen;
3778 return(TKN_DECIMAL);
3779 }
3780 }
3781 }
3782 *tkn = 0;
3783 return(TKN_FLOAT);
3784 }
3785 else
3786 {
3787 chr = *stream->ptr;
3788 *(tkn++) = *(stream->ptr++), tknLen++;
3789 switch(chr)
3790 {
3791 case '"':
3792 --tkn; --tknLen;
3793 while(*stream->ptr != '"' && *stream->ptr != 0
3794 && tknLen < MAX_STRING)
3795 {
3796 if(*stream->ptr == '\\')
3797 {
3798 stream->ptr++;
3799 if(isDigit((unsigned char)*stream->ptr) &&
3800 isDigit((unsigned char)*(stream->ptr+1)) &&
3801 isDigit((unsigned char)*(stream->ptr+2)))
3802 {
3803 memcpy(buff, stream->ptr, 3);
3804 buff[3] = 0;
3805 *(tkn++) = atoi(buff);
3806 tknLen++;
3807 stream->ptr += 3;
3808 continue;
3809 }
3810
3811 switch(*stream->ptr)
3812 {
3813 case 0:
3814 goto SRING_TO_LONG_ERROR;
3815 break;
3816 case 'n':
3817 *(tkn++) = '\n'; break;
3818 case '\\':
3819 *(tkn++) = '\\'; break;
3820 case 'b':
3821 *(tkn++) = '\b'; break;
3822 case 'f':
3823 *(tkn++) = '\f'; break;
3824 case 'r':
3825 *(tkn++) = '\r'; break;
3826 case 't':
3827 *(tkn++) = '\t'; break;
3828 case '"':
3829 *(tkn++) = '"'; break;
3830 case 'x':
3831 if(isxdigit((unsigned char)*(stream->ptr + 1)) &&
3832 isxdigit((unsigned char)*(stream->ptr + 2)))
3833 {
3834 buff[0] = '0';
3835 buff[1] = (unsigned char)*(stream->ptr + 1);
3836 buff[2] = (unsigned char)*(stream->ptr + 2);
3837 buff[3] = 0;
3838 *(tkn++) = strtol(buff, NULL, 16);
3839 stream->ptr += 2;
3840 break;
3841 }
3842 case 'u':
3843 if(isxdigit((unsigned char)*(stream->ptr + 1)) &&
3844 isxdigit((unsigned char)*(stream->ptr + 2)) &&
3845 isxdigit((unsigned char)*(stream->ptr + 3)) &&
3846 isxdigit((unsigned char)*(stream->ptr + 4)))
3847 {
3848 #ifdef SUPPORT_UTF8
3849 buff[0] = '0';
3850 buff[1] = 'x';
3851 memcpy(buff + 2, stream->ptr + 1, 4);
3852 buff[6] = 0;
3853 len = wchar_utf8(strtol(buff, NULL, 16), tkn);
3854 stream->ptr += 4;
3855 tkn += len;
3856 tknLen += len -1;
3857 #else
3858 *(tkn++) = '\\';
3859 memcpy(tkn, stream->ptr, 5);
3860 tknLen = 5;
3861 tkn += 5;
3862 stream->ptr += 4;
3863 #endif
3864 break;
3865 }
3866 default:
3867 *(tkn++) = *stream->ptr;
3868 }
3869 stream->ptr++;
3870 tknLen++;
3871 }
3872 else *(tkn++) = *(stream->ptr++), tknLen++;
3873 }
3874 if(*stream->ptr == '\"')
3875 {
3876 *tkn = 0;
3877 stream->ptr++;
3878 *ptr_len = tknLen;
3879 return(TKN_STRING);
3880 }
3881 else
3882 {
3883 goto SRING_TO_LONG_ERROR;
3884 }
3885 break;
3886
3887 case '\'':
3888 case '(':
3889 case ')':
3890 *tkn = 0;
3891 return(chr);
3892 case '{':
3893 --tkn; --tknLen;
3894 bracketBalance = 1;
3895 while(*stream->ptr != 0 && tknLen < MAX_STRING)
3896 {
3897 if(*stream->ptr == '{') ++bracketBalance;
3898 if(*stream->ptr == '}') --bracketBalance;
3899 if(bracketBalance == 0) break;
3900 *(tkn++) = *(stream->ptr++), tknLen++;
3901 }
3902 if(*stream->ptr == '}')
3903 {
3904 *tkn = 0;
3905 stream->ptr++;
3906 *ptr_len = tknLen;
3907 return(TKN_STRING);
3908 }
3909 else
3910 {
3911 goto SRING_TO_LONG_ERROR;
3912 }
3913 break;
3914
3915
3916 case ',':
3917 case ':':
3918 *tkn = 0;
3919 *ptr_len = tknLen;
3920 return(TKN_SYMBOL);
3921
3922 case '[':
3923 while( tknLen < MAX_SYMBOL && *stream->ptr != 0 && *stream->ptr != ']')
3924 *(tkn++) = *(stream->ptr++), tknLen++;
3925 if(*stream->ptr == 0) return(TKN_ERROR);
3926 *tkn++ = ']';
3927 *tkn = 0;
3928 *ptr_len = ++tknLen;
3929 stream->ptr++;
3930
3931 return(TKN_SYMBOL);
3932
3933 default:
3934 while( tknLen < MAX_SYMBOL
3935 && (unsigned char)*stream->ptr > ' '
3936 && *stream->ptr != '"' && *stream->ptr != '\''
3937 && *stream->ptr != '(' && *stream->ptr != ')'
3938 && *stream->ptr != ':' && *stream->ptr != ','
3939 && *stream->ptr != 0)
3940 *(tkn++) = *(stream->ptr++), tknLen++;
3941 *tkn = 0;
3942 *ptr_len = tknLen;
3943 if(*stream->ptr == ':')
3944 {
3945 stream->ptr++;
3946 return(TKN_CONTEXT);
3947 }
3948 return(TKN_SYMBOL);
3949 }
3950 }
3951 *tkn=0;
3952 return(TKN_ERROR);
3953
3954 SRING_TO_LONG_ERROR:
3955 *tkn = 0;
3956 errorProcExt2(ERR_STRING_TOO_LONG,
3957 stuffStringN(token, strlen(token) < 40 ? strlen(token) : 40));
3958 return(TKN_ERROR);
3959 }
3960
3961 /* -------------------------- utilities ------------------------------------ */
3962
listlen(CELL * listHead)3963 size_t listlen(CELL * listHead)
3964 {
3965 size_t len = 0;
3966
3967 while(listHead != nilCell)
3968 {
3969 len++;
3970 listHead = listHead->next;
3971 }
3972
3973 return(len);
3974 }
3975
3976 /* -------------------------- functions to get parameters ------------------ */
3977
getFlag(CELL * params)3978 int getFlag(CELL * params)
3979 {
3980 params = evaluateExpression(params);
3981 return(!isNil(params));
3982 }
3983
getInteger(CELL * params,UINT * number)3984 CELL * getInteger(CELL * params, UINT * number)
3985 {
3986 CELL * cell;
3987 #ifdef BIGINT
3988 INT64 longNum;
3989 #endif
3990
3991 cell = evaluateExpression(params);
3992
3993 #ifndef NEWLISP64
3994 if(cell->type == CELL_INT64)
3995 {
3996 if(*(INT64 *)&cell->aux > 0xFFFFFFFF) *number = 0xFFFFFFFF;
3997 else if(*(INT64 *)&cell->aux < INT32_MIN_AS_INT64) *number = 0x80000000;
3998 else *number = *(INT64 *)&cell->aux;
3999 }
4000 else if(cell->type == CELL_LONG)
4001 *number = cell->contents;
4002 else if(cell->type == CELL_FLOAT)
4003 {
4004 #ifdef WINDOWS
4005 if(isnan(*(double *)&cell->aux) || !_finite(*(double *)&cell->aux)) *number = 0;
4006 #else
4007 if(isnan(*(double *)&cell->aux)) *number = 0;
4008 #endif
4009 else if(*(double *)&cell->aux > 4294967295.0) *number = 0xFFFFFFFF;
4010 else if(*(double *)&cell->aux < -2147483648.0) *number = 0x80000000;
4011 else *number = *(double *)&cell->aux;
4012 }
4013 #else /* NEWLISP64 */
4014 if(cell->type == CELL_LONG)
4015 *number = cell->contents;
4016 else if(cell->type == CELL_FLOAT)
4017 {
4018 if(isnan(*(double *)&cell->contents)) *number = 0;
4019 else if(*(double *)&cell->contents > 9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
4020 else if(*(double *)&cell->contents < -9223372036854775808.0) *number = 0x8000000000000000LL;
4021 else *number = *(double *)&cell->contents;
4022 }
4023 #endif
4024 else
4025 {
4026 #ifdef BIGINT
4027 if(cell->type == CELL_BIGINT)
4028 {
4029 longNum = bigintToInt64(cell);
4030 *number = longNum;
4031 #ifndef NEWLISP64
4032 if(longNum > 2147483647LL || longNum < -2147483648LL)
4033 return(errorProcExt(ERR_NUMBER_OUT_OF_RANGE, cell));
4034 #endif
4035 }
4036 else
4037 #endif
4038 {
4039 *number = 0;
4040 return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
4041 }
4042 }
4043
4044 return(params->next);
4045 }
4046
4047 #ifndef NEWLISP64
getInteger64Ext(CELL * params,INT64 * number,int evalFlag)4048 CELL * getInteger64Ext(CELL * params, INT64 * number, int evalFlag)
4049 {
4050 CELL * cell;
4051
4052 if(evalFlag)
4053 cell = evaluateExpression(params);
4054 else
4055 cell = params;
4056
4057 if(cell->type == CELL_INT64)
4058 *number = *(INT64 *)&cell->aux;
4059 else if(cell->type == CELL_LONG)
4060 *number = (int)cell->contents;
4061 else if(cell->type == CELL_FLOAT)
4062 {
4063 if(isnan(*(double *)&cell->aux)) *number = 0;
4064 else if(*(double *)&cell->aux > 9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
4065 else if(*(double *)&cell->aux < -9223372036854775808.0) *number = 0x8000000000000000LL;
4066 else *number = *(double *)&cell->aux;
4067 }
4068 else /* check for bigint if size * != NULL, then return bigint address in number */
4069 {
4070 #ifdef BIGINT
4071 if(cell->type == CELL_BIGINT)
4072 *number = bigintToInt64(cell);
4073 else
4074 #endif
4075 {
4076 *number = 0;
4077 return(errorProcExt(ERR_NUMBER_EXPECTED, params));
4078 }
4079 }
4080
4081 return(params->next);
4082 }
4083
4084 #else /* NEWLISP64 */
getInteger64Ext(CELL * params,INT64 * number,int evalFlag)4085 CELL * getInteger64Ext(CELL * params, INT64 * number, int evalFlag)
4086 {
4087 CELL * cell;
4088
4089 if(evalFlag)
4090 cell = evaluateExpression(params);
4091 else
4092 cell = params;
4093
4094 if(cell->type == CELL_LONG)
4095 *number = cell->contents;
4096 else if(cell->type == CELL_FLOAT)
4097 {
4098 if(isnan(*(double *)&cell->contents)) *number = 0;
4099 else if(*(double *)&cell->contents > 9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
4100 else if(*(double *)&cell->contents < -9223372036854775808.0) *number = 0x8000000000000000LL;
4101 else *number = *(double *)&cell->contents;
4102 }
4103 else
4104 {
4105 #ifdef BIGINT
4106 if(cell->type == CELL_BIGINT)
4107 *number = bigintToInt64(cell);
4108 else
4109 #endif
4110 {
4111 *number = 0;
4112 return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
4113 }
4114 }
4115
4116 return(params->next);
4117 }
4118 #endif
4119
getIntegerExt(CELL * params,UINT * number,int evalFlag)4120 CELL * getIntegerExt(CELL * params, UINT * number, int evalFlag)
4121 {
4122 CELL * cell;
4123 #ifdef BIGINT
4124 INT64 longNum;
4125 #endif
4126
4127 if(evalFlag)
4128 cell = evaluateExpression(params);
4129 else cell = params;
4130
4131 #ifndef NEWLISP64
4132 if(cell->type == CELL_INT64)
4133 {
4134 if(*(INT64 *)&cell->aux > 0xFFFFFFFF) *number = 0xFFFFFFFF;
4135 else if(*(INT64 *)&cell->aux < INT32_MIN_AS_INT64) *number = 0x80000000;
4136 else *number = *(INT64 *)&cell->aux;
4137 }
4138 else if(cell->type == CELL_LONG)
4139 *number = cell->contents;
4140 else if(cell->type == CELL_FLOAT)
4141 {
4142 #ifdef WINDOWS
4143 if(isnan(*(double *)&cell->aux) || !_finite(*(double *)&cell->aux)) *number = 0;
4144 #else
4145 if(isnan(*(double *)&cell->aux)) *number = 0;
4146 #endif
4147 else if(*(double *)&cell->aux > 4294967295.0) *number = 0xFFFFFFFF;
4148 else if(*(double *)&cell->aux < -2147483648.0) *number = 0x80000000;
4149 else *number = *(double *)&cell->aux;
4150 }
4151 #else /* NEWLISP64 */
4152 if(cell->type == CELL_LONG)
4153 *number = cell->contents;
4154 else if(cell->type == CELL_FLOAT)
4155 {
4156 if(isnan(*(double *)&cell->contents)) *number = 0;
4157 else if(*(double *)&cell->contents > 9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
4158 else if(*(double *)&cell->contents < -9223372036854775808.0) *number = 0x8000000000000000LL;
4159 else *number = *(double *)&cell->contents;
4160 }
4161 #endif
4162 else /* if BIGNUM type throw ERR_NUMBER_OUT_OF_RANGE */
4163 {
4164 #ifdef BIGINT
4165 if(cell->type == CELL_BIGINT)
4166 {
4167 longNum = bigintToInt64(cell);
4168 *number = longNum;
4169 #ifndef NEWLISP64
4170 if(longNum > 2147483647LL || longNum < -2147483648LL)
4171 return(errorProcExt(ERR_NUMBER_OUT_OF_RANGE, cell));
4172 #endif
4173 }
4174 else
4175
4176 #endif /* BIGINT */
4177 {
4178 *number = 0;
4179 return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
4180 }
4181 }
4182
4183 return(params->next);
4184 }
4185
4186
getFloat(CELL * params,double * floatNumber)4187 CELL * getFloat(CELL * params, double * floatNumber)
4188 {
4189 CELL * cell;
4190
4191 cell = evaluateExpression(params);
4192
4193 #ifndef NEWLISP64
4194 if(cell->type == CELL_FLOAT)
4195 *floatNumber = *(double *)&cell->aux;
4196 else if(cell->type == CELL_INT64)
4197 *floatNumber = *(INT64 *)&cell->aux;
4198 #else
4199 if(cell->type == CELL_FLOAT)
4200 *floatNumber = *(double *)&cell->contents;
4201 #endif
4202 else if(cell->type == CELL_LONG)
4203 *floatNumber = (INT)cell->contents;
4204 else
4205 {
4206 #ifdef BIGINT
4207 if(cell->type == CELL_BIGINT)
4208 *floatNumber = bigintCellToFloat(cell);
4209 else
4210 #endif
4211 {
4212 *floatNumber = 0.0;
4213 return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
4214 }
4215 }
4216
4217 return(params->next);
4218 }
4219
4220
getString(CELL * params,char ** stringPtr)4221 CELL * getString(CELL * params, char * * stringPtr)
4222 {
4223 CELL * cell;
4224 SYMBOL * sPtr;
4225
4226 cell = evaluateExpression(params);
4227
4228 if(cell->type == CELL_CONTEXT)
4229 {
4230 sPtr = translateCreateSymbol( ((SYMBOL*)cell->contents)->name, CELL_NIL,
4231 (SYMBOL*)cell->contents, TRUE);
4232 cell = (CELL *)sPtr->contents;
4233 }
4234
4235 if(cell->type != CELL_STRING)
4236 {
4237 *stringPtr = "";
4238 return(errorProcArgs(ERR_STRING_EXPECTED, params));
4239 }
4240
4241 *stringPtr = (char *)cell->contents;
4242 return(params->next);
4243 }
4244
4245
getStringSize(CELL * params,char ** stringPtr,size_t * size,int evalFlag)4246 CELL * getStringSize(CELL * params, char * * stringPtr, size_t * size, int evalFlag)
4247 {
4248 CELL * cell;
4249 SYMBOL * sPtr;
4250
4251 if(evalFlag)
4252 cell = evaluateExpression(params);
4253 else
4254 cell = params;
4255
4256 if(cell->type == CELL_CONTEXT)
4257 {
4258 sPtr = translateCreateSymbol( ((SYMBOL*)cell->contents)->name, CELL_NIL,
4259 (SYMBOL*)cell->contents, TRUE);
4260 symbolCheck = sPtr;
4261 cell = (CELL *)sPtr->contents;
4262 }
4263
4264 if(cell->type != CELL_STRING)
4265 {
4266 *stringPtr = "";
4267 return(errorProcArgs(ERR_STRING_EXPECTED, params));
4268 }
4269
4270 *stringPtr = (char *)cell->contents;
4271
4272 if(size) *size = cell->aux - 1;
4273 return(params->next);
4274 }
4275
4276
getSymbol(CELL * params,SYMBOL ** symbol)4277 CELL * getSymbol(CELL * params, SYMBOL * * symbol)
4278 {
4279 CELL * cell;
4280
4281 cell = evaluateExpression(params);
4282
4283 if(cell->type != CELL_SYMBOL)
4284 {
4285 if(cell->type == CELL_DYN_SYMBOL)
4286 {
4287 *symbol = getDynamicSymbol(cell);
4288 return(params->next);
4289 }
4290 *symbol = nilSymbol;
4291 return(errorProcArgs(ERR_SYMBOL_EXPECTED, params));
4292 }
4293
4294 *symbol = (SYMBOL *)cell->contents;
4295 return(params->next);
4296 }
4297
4298 /* only used for internal syms: $timer, $error-event, $prompt-event, $command-event
4299 $transfer-event, and $signal-1-> $signal-32
4300 If a quoted symbols hasn't been passed take the evaluated params as contents
4301 of the system event symbols starting with $ */
getCreateSymbol(CELL * params,SYMBOL ** symbol,char * name)4302 CELL * getCreateSymbol(CELL * params, SYMBOL * * symbol, char * name)
4303 {
4304 CELL * cell;
4305 CELL * cellForDelete;
4306
4307 cell = evaluateExpression(params);
4308
4309 if(cell->type != CELL_SYMBOL)
4310 {
4311 if(cell->type == CELL_DYN_SYMBOL)
4312 {
4313 *symbol = getDynamicSymbol(cell);
4314 return(params->next);
4315 }
4316 *symbol = translateCreateSymbol(name, CELL_NIL, mainContext, TRUE);
4317 (*symbol)->flags |= SYMBOL_PROTECTED | SYMBOL_GLOBAL;
4318 cellForDelete = (CELL *)(*symbol)->contents;
4319 if(isNil(cell))
4320 *symbol = nilSymbol;
4321 else if(cell->type != CELL_LAMBDA && cell->type != CELL_FEXPR && cell->type != CELL_PRIMITIVE)
4322 {
4323 *symbol = nilSymbol;
4324 deleteList(cellForDelete);
4325 return(errorProcExt(ERR_INVALID_PARAMETER, params));
4326 }
4327 else if(compareCells(cellForDelete, cell) != 0)
4328 {
4329 (*symbol)->contents = (UINT)copyCell(cell);
4330 deleteList(cellForDelete);
4331 }
4332 }
4333 else
4334 *symbol = (SYMBOL *)cell->contents;
4335
4336 return(params->next);
4337 }
4338
4339
getContext(CELL * params,SYMBOL ** context)4340 CELL * getContext(CELL * params, SYMBOL * * context)
4341 {
4342 CELL * cell;
4343
4344 cell = evaluateExpression(params);
4345
4346 if(cell->type == CELL_CONTEXT || cell->type == CELL_SYMBOL)
4347 *context = (SYMBOL *)cell->contents;
4348 else
4349 {
4350 *context = NULL;
4351 return(errorProcArgs(ERR_CONTEXT_EXPECTED, params));
4352 }
4353
4354 if(symbolType(*context) != CELL_CONTEXT)
4355 return(errorProcExt(ERR_CONTEXT_EXPECTED, params));
4356
4357 return(params->next);
4358 }
4359
4360
getEvalDefault(CELL * params,CELL ** result)4361 CELL * getEvalDefault(CELL * params, CELL * * result)
4362 {
4363 CELL * cell;
4364
4365 cell = evaluateExpression(params);
4366
4367 if(cell->type == CELL_CONTEXT)
4368 {
4369 symbolCheck = translateCreateSymbol( ((SYMBOL*)cell->contents)->name, CELL_NIL,
4370 (SYMBOL*)cell->contents, TRUE);
4371 cell = (CELL *)symbolCheck->contents;
4372 }
4373
4374 *result = cell;
4375
4376 return(params->next);
4377 }
4378
4379 /* gets the first element, without list envelope in head
4380 and return the list with envelope
4381 */
getListHead(CELL * params,CELL ** head)4382 CELL * getListHead(CELL * params, CELL * * head)
4383 {
4384 CELL * cell;
4385 SYMBOL * sPtr;
4386
4387 cell = evaluateExpression(params);
4388
4389 if(cell->type == CELL_CONTEXT)
4390 {
4391 sPtr = translateCreateSymbol( ((SYMBOL*)cell->contents)->name, CELL_NIL,
4392 (SYMBOL*)cell->contents, TRUE);
4393 cell = (CELL *)sPtr->contents;
4394 }
4395
4396 if(!isList(cell->type))
4397 {
4398 *head = nilCell;
4399 return(errorProcExt(ERR_LIST_EXPECTED, params));
4400 }
4401
4402 *head = (CELL *)cell->contents;
4403
4404 return(params->next);
4405 }
4406
4407 /* ------------------------------- core predicates ------------------------ */
4408
p_setLocale(CELL * params)4409 CELL * p_setLocale(CELL * params)
4410 {
4411 #ifndef ANDROID
4412 struct lconv * lc;
4413 #endif
4414 char * locale;
4415 UINT category;
4416 CELL * cell;
4417
4418 if(params != nilCell)
4419 params = getString(params, &locale);
4420 else locale = NULL;
4421
4422 getEvalDefault(params, &cell);
4423 if(isNumber(cell->type)) /* second parameter */
4424 getIntegerExt(cell, &category, FALSE);
4425 else category = LC_ALL;
4426
4427 locale = setlocale(category, locale);
4428
4429 if(locale == NULL)
4430 return(nilCell);
4431
4432 stringOutputRaw = (strcmp(locale, "C") == 0);
4433
4434 #ifndef ANDROID
4435 lc = localeconv();
4436 lc_decimal_point = *lc->decimal_point;
4437 #endif
4438 cell = getCell(CELL_EXPRESSION);
4439 addList(cell, stuffString(locale));
4440 #ifdef ANDROID
4441 addList(cell, stuffStringN(".", 1));
4442 #else
4443 addList(cell, stuffStringN(lc->decimal_point, 1));
4444 #endif
4445 return(cell);
4446 }
4447
p_quote(CELL * params)4448 CELL * p_quote(CELL * params)
4449 {
4450 return(copyCell(params));
4451 }
4452
4453
p_eval(CELL * params)4454 CELL * p_eval(CELL * params)
4455 {
4456 CELL * result;
4457
4458 params = evaluateExpression(params);
4459 result = evaluateExpression(params);
4460 pushResultFlag = FALSE;
4461 return(result);
4462 }
4463
4464
p_catch(CELL * params)4465 CELL * p_catch(CELL * params)
4466 {
4467 jmp_buf errorJumpSave;
4468 UINT * envStackIdxSave;
4469 UINT * lambdaStackIdxSave;
4470 int recursionCountSave;
4471 int value;
4472 CELL * expr;
4473 CELL * result;
4474 SYMBOL * symbol = NULL;
4475 SYMBOL * contextSave;
4476 CELL * objSave;
4477 CELL * objCellSave;
4478
4479 expr = params;
4480 if(params->next != nilCell)
4481 {
4482 getSymbol(params->next, &symbol);
4483 if(isProtected(symbol->flags))
4484 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
4485 }
4486
4487 memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
4488 /* save general environment */
4489 envStackIdxSave = envStackIdx;
4490 recursionCountSave = recursionCount;
4491 lambdaStackIdxSave = lambdaStackIdx;
4492 contextSave = currentContext;
4493 /* save FOOP environment */
4494 objSave = (CELL *)objSymbol.contents;
4495 objCellSave = objCell;
4496 itSymbol->contents = (UINT)nilCell;
4497
4498 if((value = setjmp(errorJump)) != 0)
4499 {
4500 memcpy(errorJump, errorJumpSave, (sizeof(jmp_buf)));
4501 /* restore general environment */
4502 recoverEnvironment(envStackIdxSave);
4503 recursionCount = recursionCountSave;
4504 lambdaStackIdx = lambdaStackIdxSave;
4505 currentContext = contextSave;
4506 /* restore FOOP environment */
4507 objSymbol.contents = (UINT)objSave;
4508 objCell = objCellSave;
4509
4510 evalCatchFlag--;
4511 if(value == EXCEPTION_THROW)
4512 {
4513 if(symbol == NULL) return(throwResult);
4514 deleteList((CELL*)symbol->contents);
4515 symbol->contents = (UINT)throwResult;
4516 return(trueCell);
4517 }
4518
4519 if(errorStream.buffer != NULL)
4520 {
4521 if(symbol == NULL)
4522 {
4523 if(errorEvent == nilSymbol && evalCatchFlag == 0)
4524 varPrintf(OUT_CONSOLE, "\n%.1024s\n", errorStream.buffer);
4525 longjmp(errorJump, value);
4526 }
4527 deleteList((CELL*)symbol->contents);
4528 symbol->contents = (UINT)stuffString(errorStream.buffer);
4529 }
4530
4531 return(nilCell);
4532 }
4533
4534 evalCatchFlag++;
4535 result = copyCell(evaluateExpression(expr));
4536 evalCatchFlag--;
4537 memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
4538
4539 if(symbol == NULL) return(result);
4540
4541 deleteList((CELL*)symbol->contents);
4542 symbol->contents = (UINT)result;
4543
4544 return(trueCell);
4545 }
4546
4547
p_throw(CELL * params)4548 CELL * p_throw(CELL * params)
4549 {
4550 if(evalCatchFlag == 0)
4551 return(errorProc(ERR_THROW_WO_CATCH));
4552
4553 throwResult = copyCell(evaluateExpression(params));
4554 longjmp(errorJump, EXCEPTION_THROW);
4555
4556 return(trueCell);
4557 }
4558
p_throwError(CELL * params)4559 CELL * p_throwError(CELL * params)
4560 {
4561 evalFunc = NULL;
4562 errorProcExt(ERR_USER_ERROR, evaluateExpression(params));
4563 return(nilCell);
4564 }
4565
4566 CELL * evalString(CELL * params, int mode);
4567
p_evalString(CELL * params)4568 CELL * p_evalString(CELL * params) { return(evalString(params, EVAL_STRING)); }
p_readExpr(CELL * params)4569 CELL * p_readExpr(CELL * params) { return(evalString(params, READ_EXPR)); }
4570
evalString(CELL * params,int mode)4571 CELL * evalString(CELL * params, int mode)
4572 {
4573 SYMBOL * context = currentContext;
4574 char * evalStr;
4575
4576 params = getString(params, &evalStr);
4577
4578 if(params != nilCell)
4579 {
4580 if((context = getCreateContext(params, TRUE)) == NULL)
4581 return(errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, params));
4582 }
4583
4584 if(mode == EVAL_STRING)
4585 return(copyCell(sysEvalString(evalStr, context, params->next, mode)));
4586
4587 /* returns a new object not yet marked for deletion */
4588 return(sysEvalString(evalStr, context, params->next, mode));
4589 }
4590
4591 /* modes:
4592 EVAL_STRING
4593 the classic eval-string: read the string, compile to s-expression , evaluate
4594 READ_EXPR_SYNC
4595 used by p_sync() in nl-filesys.c
4596 READ_EXPR
4597 used by p_readExpr
4598 READ_EXPR_NET
4599 used by p_netEval introduces in 10.6.3, before READ_EXPR_SYNC was used
4600 */
4601
4602
sysEvalString(char * evalString,SYMBOL * context,CELL * proc,int mode)4603 CELL * sysEvalString(char * evalString, SYMBOL * context, CELL * proc, int mode)
4604 {
4605 CELL * program;
4606 STREAM stream;
4607 CELL * resultCell = nilCell;
4608 SYMBOL * contextSave = NULL;
4609 UINT * resultIdxSave;
4610 jmp_buf errorJumpSave;
4611 int recursionCountSave;
4612 UINT * envStackIdxSave;
4613 UINT offset;
4614 CELL * xlate;
4615
4616 makeStreamFromString(&stream, evalString);
4617 if(proc->next != nilCell)
4618 {
4619 getInteger(proc->next, &offset);
4620 stream.ptr += offset;
4621 }
4622
4623 resultIdxSave = resultStackIdx;
4624 contextSave = currentContext;
4625 currentContext = context;
4626
4627 if(proc != nilCell)
4628 {
4629 recursionCountSave = recursionCount;
4630 envStackIdxSave = envStackIdx;
4631 evalCatchFlag++;
4632 memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
4633
4634 if(setjmp(errorJump) != 0)
4635 {
4636 memcpy(errorJump, errorJumpSave, (sizeof(jmp_buf)));
4637 recoverEnvironment(envStackIdxSave);
4638 evalCatchFlag--;
4639 recursionCount = recursionCountSave;
4640 currentContext = contextSave;
4641 if(mode == READ_EXPR)
4642 return(copyCell(evaluateExpression(proc)));
4643 return(evaluateExpression(proc));
4644 }
4645 }
4646
4647 while(TRUE)
4648 {
4649 pushResult(program = getCell(CELL_QUOTE));
4650 if(compileExpression(&stream, program) == 0)
4651 break;
4652 if(readerEvent != nilSymbol)
4653 {
4654 --resultStackIdx;
4655 executeSymbol(readerEvent, program, &xlate);
4656 pushResult(program = makeCell(CELL_QUOTE, (UINT)xlate));
4657 }
4658 if(mode == EVAL_STRING)
4659 resultCell = evaluateExpression((CELL *)program->contents);
4660 else /* READ_EXPR, READ_EXPR_SYNC, READ_EXPR_NET */
4661 {
4662 if(resultCell != nilCell) pushResult(resultCell); /* 10.6.3 */
4663 countCell->contents = (UINT)(stream.ptr - stream.buffer);
4664 resultCell = (CELL *)program->contents;
4665 program->contents = (UINT)nilCell; /* de-couple */
4666 if(mode == READ_EXPR_SYNC || mode == READ_EXPR) /* 10.6.3 */
4667 break; /* only do first expression */
4668 }
4669
4670 if(resultStackIdx > resultStackTop - 256)
4671 {
4672 program = popResult(); /* leave last result */
4673 cleanupResults(resultIdxSave);
4674 pushResult(program);
4675 }
4676 }
4677
4678 currentContext = contextSave;
4679
4680 if(proc != nilCell)
4681 {
4682 memcpy(errorJump, errorJumpSave, (sizeof(jmp_buf)));
4683 evalCatchFlag--;
4684 }
4685
4686 return(resultCell);
4687 }
4688
4689 #ifdef EMSCRIPTEN
4690 extern char *emscripten_run_script_string(const char *script);
4691 char * evalJSbuff = NULL;
4692
evalStringJS(char * cmd,size_t len)4693 char * evalStringJS(char * cmd, size_t len)
4694 {
4695 if(evalJSbuff != NULL) free(evalJSbuff);
4696
4697 evalJSbuff = callocMemory(len + 1);
4698 memcpy(evalJSbuff, cmd, len);
4699
4700 return(emscripten_run_script_string(evalJSbuff));
4701 }
4702
4703
p_evalStringJS(CELL * params)4704 CELL * p_evalStringJS(CELL * params)
4705 {
4706 char * cmd;
4707 size_t len;
4708 char * result;
4709
4710 getStringSize(params, &cmd, &len, TRUE);
4711 result = evalStringJS(cmd, len);
4712
4713 return(stuffString(result));
4714 }
4715 #endif
4716
4717
p_curry(CELL * params)4718 CELL * p_curry(CELL * params)
4719 {
4720 CELL * lambda;
4721 CELL * cell;
4722
4723 cell = makeCell(CELL_EXPRESSION, (UINT)stuffSymbol(sysxSymbol));
4724 lambda = makeCell(CELL_LAMBDA, (UINT)cell);
4725 cell->next = getCell(CELL_EXPRESSION);
4726 cell = cell->next;
4727 cell->contents = (UINT)copyCell(params);
4728 cell = (CELL *)cell->contents;
4729 /* take left parameter */
4730 cell->next = copyCell(params->next);
4731 cell = cell->next;
4732 cell->next = stuffSymbol(sysxSymbol);
4733 /* take right parameter
4734 cell->next = stuffSymbol(sysxSymbol);
4735 cell = cell->next;
4736 cell->next = copyCell(params->next);
4737 */
4738 return(lambda);
4739 }
4740
4741
p_apply(CELL * params)4742 CELL * p_apply(CELL * params)
4743 {
4744 CELL * expr;
4745 CELL * args;
4746 CELL * cell;
4747 CELL * result;
4748 CELL * func;
4749 ssize_t count = 0, cnt;
4750 UINT * resultIdxSave;
4751
4752 func = evaluateExpression(params);
4753 params = getEvalDefault(params->next, &args);
4754 cell = copyCell(func);
4755 expr = makeCell(CELL_EXPRESSION, (UINT)cell);
4756
4757 if(args->type == CELL_ARRAY)
4758 {
4759 args = arrayList(args, FALSE);
4760 pushResult(args);
4761 }
4762
4763 if(args->type != CELL_EXPRESSION)
4764 {
4765 pushResult(expr);
4766 if(isNil(args))
4767 return(copyCell(evaluateExpression(expr)));
4768 else
4769 return(errorProcExt(ERR_LIST_EXPECTED, args));
4770 }
4771
4772 args = (CELL *)args->contents;
4773
4774 if(params != nilCell)
4775 getInteger(params, (UINT *)&count);
4776 if(count < 2) count = MAX_LONG;
4777 cnt = count;
4778
4779 resultIdxSave = resultStackIdx + 2;
4780 for(;;)
4781 {
4782 while(args != nilCell && cnt--)
4783 {
4784 if(isSelfEval(args->type))
4785 cell->next = copyCell(args);
4786 else
4787 cell->next = makeCell(CELL_QUOTE, (UINT)copyCell(args));
4788 cell = cell->next;
4789 args = args->next;
4790 }
4791 pushResult(expr);
4792 if(args == nilCell)
4793 {
4794 result = evaluateExpression(expr);
4795 if(symbolCheck)
4796 {
4797 pushResultFlag = FALSE;
4798 return(result);
4799 }
4800 else return(copyCell(result));
4801 }
4802 result = copyCell(evaluateExpression(expr));
4803 cell = copyCell(func);
4804 expr = makeCell(CELL_EXPRESSION, (UINT)cell);
4805 cell->next = makeCell(CELL_QUOTE, (UINT)result);
4806 cell = cell->next;
4807 cnt = count - 1;
4808 cleanupResults(resultIdxSave);
4809 }
4810 }
4811
p_args(CELL * params)4812 CELL * p_args(CELL * params)
4813 {
4814 if(params != nilCell)
4815 return(copyCell(implicitIndexList((CELL*)argsSymbol->contents, params)));
4816 return(copyCell((CELL*)argsSymbol->contents));
4817 }
4818
4819 /* in-place expansion, if symbol==NULL all uppercase, non-nil vars are expanded */
expand(CELL * expr,SYMBOL * symbol)4820 CELL * expand(CELL * expr, SYMBOL * symbol)
4821 {
4822 CELL * cell = nilCell;
4823 SYMBOL * sPtr;
4824 int enable = 1;
4825 CELL * cont;
4826 int wchar;
4827
4828 if(isList(expr->type) || expr->type == CELL_QUOTE)
4829 cell = (CELL*)expr->contents;
4830 else if(expr->type == CELL_SYMBOL && expr->contents == (UINT)symbol)
4831 expandExprSymbol(expr, symbol);
4832
4833 while(cell != nilCell)
4834 {
4835 if(cell->type == CELL_SYMBOL && (cell->contents == (UINT)symbol || symbol == NULL) )
4836 {
4837 sPtr = (SYMBOL *)cell->contents;
4838 if(symbol == NULL)
4839 {
4840 #ifndef SUPPORT_UTF8
4841 wchar = *sPtr->name;
4842 #else
4843 utf8_wchar(sPtr->name, &wchar);
4844 #endif
4845 enable = (wchar > 64 && wchar < 91);
4846 cont = (CELL*)sPtr->contents;
4847 enable = (enable && cont->contents != (UINT)nilCell
4848 && cont->contents != (UINT)nilSymbol);
4849 }
4850
4851 if(symbol || enable)
4852 expandExprSymbol(cell, sPtr);
4853 }
4854
4855 else if(isEnvelope(cell->type)) expand(cell, symbol);
4856 cell = cell->next;
4857 }
4858
4859 return(expr);
4860 }
4861
4862
expandExprSymbol(CELL * cell,SYMBOL * sPtr)4863 void expandExprSymbol(CELL * cell, SYMBOL * sPtr)
4864 {
4865 CELL * rep;
4866
4867 rep = copyCell((CELL*)sPtr->contents);
4868 /* check for and undo copyCell optimization */
4869 while((UINT)rep == sPtr->contents)
4870 rep = copyCell((CELL*)sPtr->contents);
4871
4872 cell->type = rep->type;
4873 cell->aux = rep->aux;
4874 cell->contents = rep->contents;
4875 rep->type = CELL_LONG;
4876 deleteList(rep);
4877 }
4878
4879
4880 /* expands one or a chain of expressions */
4881
blockExpand(CELL * block,SYMBOL * symbol)4882 CELL * blockExpand(CELL * block, SYMBOL * symbol)
4883 {
4884 CELL * expanded = nilCell;
4885 CELL * next = nilCell;
4886
4887 while(block != nilCell)
4888 {
4889 if(expanded == nilCell)
4890 {
4891 next = expand(copyCell(block), symbol);
4892 expanded = next;
4893 }
4894 else
4895 {
4896 next->next = expand(copyCell(block), symbol);
4897 next = next->next;
4898 }
4899 block = block->next;
4900 }
4901
4902 return(expanded);
4903 }
4904
4905
p_expand(CELL * params)4906 CELL * p_expand(CELL * params)
4907 {
4908 SYMBOL * symbol;
4909 CELL * expr;
4910 CELL * next;
4911 CELL * list;
4912 CELL * cell;
4913 int evalFlag;
4914
4915 params = getEvalDefault(params, &expr);
4916
4917 if((next = params) == nilCell)
4918 return(expand(copyCell(expr), NULL));
4919
4920 while((params = next) != nilCell)
4921 {
4922 next = params->next;
4923 params = evaluateExpression(params);
4924 if(params->type == CELL_SYMBOL)
4925 symbol = (SYMBOL*)params->contents;
4926 else if(params->type == CELL_DYN_SYMBOL)
4927 symbol = getDynamicSymbol(params);
4928 else if(params->type == CELL_EXPRESSION)
4929 {
4930 evalFlag = getFlag(next);
4931 list = (CELL*)params->contents; /* expansion assoc list */
4932 while(list != nilCell)
4933 {
4934 if(list->type != CELL_EXPRESSION)
4935 return(errorProcExt(ERR_LIST_EXPECTED, list));
4936 cell = (CELL *)list->contents;
4937 if(cell->type != CELL_SYMBOL)
4938 return(errorProcExt(ERR_SYMBOL_EXPECTED, cell));
4939 symbol = (SYMBOL*)cell->contents;
4940 pushEnvironment(symbol->contents);
4941 pushEnvironment(symbol);
4942 if(evalFlag)
4943 symbol->contents = (UINT)copyCell(evaluateExpression(cell->next));
4944 else
4945 symbol->contents = (UINT)cell->next;
4946 expr = expand(copyCell(expr), symbol);
4947 if(evalFlag) deleteList((CELL *)symbol->contents);
4948 symbol = (SYMBOL*)popEnvironment();
4949 symbol->contents = popEnvironment();
4950 pushResult(expr);
4951 list = list->next;
4952 continue;
4953 }
4954 break;
4955 }
4956 else
4957 return(errorProcExt(ERR_LIST_OR_SYMBOL_EXPECTED, params));
4958 expr = expand(copyCell(expr), symbol);
4959 pushResult(expr);
4960 }
4961
4962 return(copyCell(expr));
4963 }
4964
4965
defineOrMacro(CELL * params,UINT cellType,int flag)4966 CELL * defineOrMacro(CELL * params, UINT cellType, int flag)
4967 {
4968 SYMBOL * symbol;
4969 CELL * argsPtr;
4970 CELL * lambda;
4971 CELL * args;
4972 CELL * body;
4973 CELL * cell;
4974
4975 if(params->type != CELL_EXPRESSION)
4976 return(errorProcExt(ERR_LIST_OR_SYMBOL_EXPECTED, params));
4977
4978 /* symbol to be defined */
4979 argsPtr = (CELL *)params->contents;
4980 if(argsPtr->type != CELL_SYMBOL)
4981 {
4982 if(argsPtr->type == CELL_DYN_SYMBOL)
4983 symbol = getDynamicSymbol(argsPtr);
4984 else
4985 return(errorProcExt(ERR_SYMBOL_EXPECTED, params));
4986 }
4987 else symbol = (SYMBOL *)argsPtr->contents;
4988
4989 if(isProtected(symbol->flags))
4990 return(errorProc(ERR_SYMBOL_PROTECTED));
4991
4992 /* local symbols */
4993 argsPtr = copyList(argsPtr->next);
4994
4995 args = getCell(CELL_EXPRESSION);
4996 args->contents = (UINT)argsPtr;
4997 /* body expressions */
4998 body = copyList(params->next);
4999
5000 /* if expansion macro insert expand symbol for body expansion
5001 (expand 'body) */
5002 if(flag)
5003 {
5004 if(body->next != nilCell)
5005 {
5006 /* body has multiple expressions (expand '(begin ...)) */
5007 cell = stuffSymbol(beginSymbol);
5008 cell->next = body;
5009 body = makeCell(CELL_EXPRESSION, (UINT)cell);
5010 }
5011 cell = stuffSymbol(expandSymbol);
5012 cell->next = makeCell(CELL_QUOTE, (UINT)body);
5013 body = makeCell(CELL_EXPRESSION, (UINT)cell);
5014 symbol->flags |= SYMBOL_MACRO;
5015 }
5016
5017 args->next = body;
5018 lambda = makeCell(cellType, (UINT)args);
5019
5020 deleteList((CELL *)symbol->contents);
5021 symbol->contents = (UINT)lambda;
5022
5023 pushResultFlag = FALSE;
5024 return(lambda);
5025 }
5026
5027
p_define(CELL * params)5028 CELL * p_define(CELL * params)
5029 {
5030 if(params->type != CELL_SYMBOL)
5031 {
5032 if(params->type != CELL_DYN_SYMBOL)
5033 return(defineOrMacro(params, CELL_LAMBDA, FALSE));
5034 return(setDefine(getDynamicSymbol(params), params->next, SET_SET));
5035 }
5036
5037 return(setDefine((SYMBOL *)params->contents, params->next, SET_SET));
5038 }
5039
p_defineMacro(CELL * params)5040 CELL * p_defineMacro(CELL * params)
5041 {
5042 return(defineOrMacro(params, CELL_FEXPR, FALSE));
5043 }
5044
p_macro(CELL * params)5045 CELL * p_macro(CELL * params)
5046 {
5047 return(defineOrMacro(params, CELL_FEXPR, TRUE));
5048 }
5049
5050 /* also called from setq */
p_setf(CELL * params)5051 CELL * p_setf(CELL *params)
5052 {
5053 SYMBOL * symbolRef = NULL;
5054 CELL * cell;
5055 CELL * new;
5056 CELL * stringRef;
5057 char * indexRefPtr;
5058
5059 SETF_BEGIN:
5060 if(params->next == nilCell)
5061 return(errorProc(ERR_MISSING_ARGUMENT));
5062
5063 cell = evaluateExpression(params);
5064
5065 if(cell == nilCell || cell == trueCell)
5066 errorProcExt(ERR_IS_NOT_REFERENCED, cell);
5067
5068 symbolRef = symbolCheck;
5069 stringRef = stringCell;
5070 indexRefPtr = stringIndexPtr;
5071
5072 if(symbolRef && isProtected(symbolRef->flags) && symbolRef->contents == (UINT)cell)
5073 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbolRef)));
5074
5075 itSymbol->contents = (UINT)cell;
5076 new = copyCell(evaluateExpression(params->next));
5077 itSymbol->contents = (UINT)nilCell;
5078
5079 params = params->next;
5080 params = params->next;
5081
5082
5083 if(stringRef && indexRefPtr)
5084 {
5085 cell = setNthStr((CELL *)stringRef, new, indexRefPtr);
5086 if(params != nilCell) goto SETF_BEGIN;
5087 return(cell);
5088 }
5089
5090 /* delete contents of original cell */
5091 if(isEnvelope(cell->type))
5092 {
5093 if(cell->type == CELL_ARRAY)
5094 deleteArray(cell);
5095 else
5096 deleteList((CELL *)cell->contents);
5097 }
5098 else if(cell->type == CELL_STRING || cell->type == CELL_DYN_SYMBOL
5099 #ifdef BIGINT
5100 || cell->type == CELL_BIGINT
5101 #endif
5102 )
5103 freeMemory( (void *)cell->contents);
5104
5105
5106 /* get new contents */
5107 cell->type = new->type;
5108 cell->aux = new->aux;
5109 cell->contents = new->contents;
5110
5111 /* free cell */
5112 new->type = CELL_FREE;
5113 new->aux = 0;
5114 new->contents = 0;
5115 new->next = firstFreeCell;
5116 firstFreeCell = new;
5117 --cellCount;
5118
5119 if(params != nilCell) goto SETF_BEGIN;
5120
5121 /* return modified cell */
5122 symbolCheck = symbolRef;
5123 pushResultFlag = FALSE;
5124 return(cell);
5125 }
5126
5127
p_set(CELL * params)5128 CELL * p_set(CELL *params)
5129 {
5130 SYMBOL * symbol;
5131 CELL * next;
5132
5133 for(;;)
5134 {
5135 params = getSymbol(params, &symbol);
5136 next = params->next;
5137 if(params == nilCell)
5138 return(errorProc(ERR_MISSING_ARGUMENT));
5139 pushResultFlag = TRUE;
5140 if(next == nilCell) return(setDefine(symbol, params, SET_SET));
5141 setDefine(symbol, params, SET_SET);
5142 params = next;
5143 }
5144 }
5145
5146
p_constant(CELL * params)5147 CELL * p_constant(CELL *params)
5148 {
5149 SYMBOL * symbol;
5150 CELL * next;
5151 UINT * idx = envStackIdx;
5152
5153 for(;;)
5154 {
5155 params = getSymbol(params, &symbol);
5156 /* make sure symbol is not used as local in call hierachy */
5157 while(idx > envStack)
5158 {
5159 if(symbol == (SYMBOL *)*(--idx))
5160 errorProcExt2(ERR_CANNOT_PROTECT_LOCAL, stuffSymbol(symbol));
5161 --idx;
5162 }
5163
5164 /* protect contexts from being set, but not vars holding contexts */
5165 if((symbolType(symbol) == CELL_CONTEXT && (SYMBOL *)((CELL *)symbol->contents)->contents == symbol)
5166 || symbol == countSymbol)
5167 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
5168 next = params->next;
5169 if(symbol->context != currentContext)
5170 return(errorProcExt2(ERR_NOT_CURRENT_CONTEXT, stuffSymbol(symbol)));
5171 symbol->flags |= SYMBOL_PROTECTED;
5172 if(params == nilCell)
5173 return(copyCell((CELL*)symbol->contents));
5174 if(next == nilCell)
5175 {
5176 next = setDefine(symbol, params, SET_CONSTANT);
5177 pushResultFlag = TRUE;
5178 return(copyCell(next));
5179 }
5180 setDefine(symbol, params, SET_CONSTANT);
5181 pushResultFlag = TRUE;
5182 params = next;
5183 }
5184 }
5185
5186
setDefine(SYMBOL * symbol,CELL * params,int type)5187 CELL * setDefine(SYMBOL * symbol, CELL * params, int type)
5188 {
5189 CELL * cell;
5190
5191 if(isProtected(symbol->flags))
5192 {
5193 if(type == SET_CONSTANT)
5194 {
5195 if(symbol == nilSymbol || symbol == trueSymbol)
5196 return(errorProcExt2(ERR_SYMBOL_EXPECTED, stuffSymbol(symbol)));
5197 }
5198 else
5199 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
5200 }
5201
5202 cell = copyCell(evaluateExpression(params));
5203
5204 deleteList((CELL *)symbol->contents);
5205 symbol->contents = (UINT)(cell);
5206
5207 symbolCheck = symbol;
5208 pushResultFlag = FALSE;
5209
5210 return(cell);
5211 }
5212
5213
p_global(CELL * params)5214 CELL * p_global(CELL * params)
5215 {
5216 SYMBOL * sPtr;
5217
5218 do
5219 {
5220 params = getSymbol(params, &sPtr);
5221 if(sPtr->context != mainContext || currentContext != mainContext)
5222 return(errorProcExt2(ERR_NOT_IN_MAIN, stuffSymbol(sPtr)));
5223 else
5224 sPtr->flags |= SYMBOL_GLOBAL;
5225 } while (params != nilCell);
5226
5227 return(stuffSymbol(sPtr));
5228 }
5229
5230 #define LET_STD 0
5231 #define LET_NEST 1
5232 #define LET_EXPAND 2
5233 #define LET_LOCAL 3
5234
5235 CELL * let(CELL * params, int type);
5236
p_let(CELL * params)5237 CELL * p_let(CELL * params) { return(let(params, LET_STD)); }
p_letn(CELL * params)5238 CELL * p_letn(CELL * params) { return(let(params, LET_NEST)); }
p_letExpand(CELL * params)5239 CELL * p_letExpand(CELL * params) { return(let(params, LET_EXPAND)); }
p_local(CELL * params)5240 CELL * p_local(CELL * params) { return(let(params, LET_LOCAL)); }
5241
let(CELL * params,int type)5242 CELL * let(CELL * params, int type)
5243 {
5244 CELL * inits;
5245 CELL * cell;
5246 CELL * result = nilCell;
5247 CELL * args = NULL, * list = NULL;
5248 CELL * body;
5249 SYMBOL * symbol;
5250 int localCount = 0;
5251
5252 if(params->type != CELL_EXPRESSION)
5253 return(errorProcExt(ERR_INVALID_LET, params));
5254
5255 /* evaluate symbol assignments in parameter list
5256 handle double syntax classic: (let ((s1 e1) (s2 e2) ...) ...)
5257 and: (let (s1 e1 s2 e2 ...) ...)
5258 */
5259 inits = (CELL*)params->contents;
5260 body = params->next;
5261
5262 if(type == LET_LOCAL)
5263 {
5264 while(inits != nilCell)
5265 {
5266 if(inits->type != CELL_SYMBOL)
5267 return(errorProcExt(ERR_SYMBOL_EXPECTED, inits));
5268 symbol = (SYMBOL *)inits->contents;
5269 if(isProtected(symbol->flags))
5270 return(errorProcExt(ERR_SYMBOL_PROTECTED, inits));
5271 pushEnvironment(symbol->contents);
5272 pushEnvironment(symbol);
5273 symbol->contents = (UINT)copyCell(nilCell);
5274 localCount++;
5275 inits = inits->next;
5276 }
5277 goto EVAL_LET_BODY;
5278 }
5279
5280 while(inits != nilCell)
5281 {
5282 if(inits->type != CELL_EXPRESSION)
5283 {
5284 if(inits->type != CELL_SYMBOL)
5285 return(errorProcExt(ERR_INVALID_LET, inits));
5286 cell = inits;
5287 inits = ((CELL*)cell->next)->next;
5288 }
5289 else
5290 {
5291 cell = (CELL *)inits->contents;
5292 if(cell->type != CELL_SYMBOL)
5293 return(errorProcExt(ERR_SYMBOL_EXPECTED, inits));
5294 inits = inits->next;
5295 }
5296
5297 if(type == LET_STD || type == LET_EXPAND)
5298 {
5299 if(localCount == 0)
5300 list = args = copyCell(evaluateExpression(cell->next));
5301 else
5302 {
5303 args->next = copyCell(evaluateExpression(cell->next));
5304 args = args->next;
5305 }
5306 }
5307 else /* LET_NEST */
5308 {
5309 symbol = (SYMBOL *)cell->contents;
5310 if(isProtected(symbol->flags))
5311 return(errorProcExt(ERR_SYMBOL_PROTECTED, cell));
5312 args = copyCell(evaluateExpression(cell->next));
5313 pushEnvironment((CELL *)symbol->contents);
5314 pushEnvironment((UINT)symbol);
5315 symbol->contents = (UINT)args;
5316 }
5317
5318 localCount++;
5319 }
5320
5321 /* save symbols and get new bindings */
5322 if(type == LET_STD || type == LET_EXPAND)
5323 {
5324 inits = (CELL*)params->contents;
5325 while(inits != nilCell)
5326 {
5327 if(inits->type == CELL_EXPRESSION)
5328 {
5329 cell = (CELL *)inits->contents;
5330 inits = inits->next;
5331 }
5332 else
5333 {
5334 cell = inits;
5335 inits = ((CELL*)cell->next)->next;
5336 }
5337
5338 symbol = (SYMBOL *)cell->contents;
5339
5340 if(isProtected(symbol->flags))
5341 return(errorProcExt(ERR_SYMBOL_PROTECTED, cell));
5342
5343 pushEnvironment((CELL *)symbol->contents);
5344 pushEnvironment((UINT)symbol);
5345 symbol->contents = (UINT)list;
5346
5347 args = list;
5348 list = list->next;
5349 args->next = nilCell; /* decouple */
5350
5351 /* hook in LET_EXPAND mode here */
5352 if(type == LET_EXPAND)
5353 {
5354 body = blockExpand(body, symbol);
5355 pushResult(body);
5356 }
5357
5358 }
5359 }
5360
5361 EVAL_LET_BODY:
5362 /* evaluate body expressions */
5363 while(body != nilCell)
5364 {
5365 if(result != nilCell) deleteList(result);
5366 result = copyCell(evaluateExpression(body));
5367 body = body->next;
5368 }
5369
5370 /* restore environment */
5371 while(localCount--)
5372 {
5373 symbol = (SYMBOL *)popEnvironment();
5374 deleteList((CELL *)symbol->contents);
5375 symbol->contents = popEnvironment();
5376 }
5377
5378 return(result);
5379 }
5380
p_first(CELL * params)5381 CELL * p_first(CELL * params)
5382 {
5383 char str[2];
5384 CELL * cell;
5385 CELL * result;
5386 #ifdef SUPPORT_UTF8
5387 size_t len;
5388 #endif
5389
5390 getEvalDefault(params, &cell);
5391
5392 if(cell->type == CELL_STRING)
5393 {
5394 stringCell = cell;
5395 if((str[0] = *(char *)cell->contents) == 0)
5396 return(stuffString(""));
5397
5398 #ifndef SUPPORT_UTF8
5399 str[1] = 0;
5400 result = stuffString(str);
5401 #else
5402 len = utf8_1st_len((char*)cell->contents);
5403 if(len > cell->aux -1)
5404 return(errorProc(ERR_INVALID_UTF8));
5405 result = stuffStringN((char*)cell->contents, len);
5406 #endif
5407
5408 stringIndexPtr = (char *)cell->contents;
5409 if(symbolCheck)
5410 {
5411 pushResult(result);
5412 pushResultFlag = FALSE;
5413 }
5414 return(result);
5415 }
5416
5417 else if(isList(cell->type))
5418 {
5419 if(cell->contents == (UINT)nilCell)
5420 return(errorProcExt(ERR_LIST_EMPTY, params));
5421
5422 pushResultFlag = FALSE;
5423 return((CELL *)cell->contents);
5424 }
5425
5426 else if(cell->type == CELL_ARRAY)
5427 {
5428 pushResultFlag = FALSE;
5429 return(*(CELL * *)cell->contents);
5430 }
5431
5432 return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, params));
5433 }
5434
5435
p_rest(CELL * params)5436 CELL * p_rest(CELL * params)
5437 {
5438 CELL * cell;
5439 CELL * tail;
5440 #ifdef SUPPORT_UTF8
5441 size_t size;
5442 #endif
5443
5444 /* cell = evaluateExpression(params); */
5445 getEvalDefault(params, &cell);
5446
5447 if(isList(cell->type))
5448 {
5449 tail = makeCell(CELL_EXPRESSION, (UINT)copyList(((CELL*)cell->contents)->next));
5450 return(tail);
5451 }
5452 else if(cell->type == CELL_ARRAY)
5453 return(subarray(cell, 1, MAX_LONG));
5454
5455 else if(cell->type == CELL_STRING)
5456 {
5457 if(*(char *)cell->contents == 0)
5458 return(stuffString(""));
5459 #ifndef SUPPORT_UTF8
5460 return(stuffString((char *)(cell->contents + 1)));
5461 #else
5462 size = utf8_1st_len((char *)cell->contents);
5463 if(size > cell->aux - 1)
5464 return(errorProc(ERR_INVALID_UTF8));
5465 return(stuffString((char *)(cell->contents + size)));
5466 #endif
5467 }
5468
5469 return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, params));
5470 }
5471
implicitNrestSlice(CELL * num,CELL * params)5472 CELL * implicitNrestSlice(CELL * num, CELL * params)
5473 {
5474 CELL * list;
5475 ssize_t n, len;
5476
5477 getIntegerExt(num, (UINT *)&n, FALSE);
5478 list = evaluateExpression(params);
5479
5480 if(list->type == CELL_CONTEXT)
5481 list = (CELL *)(translateCreateSymbol(
5482 ((SYMBOL*)list->contents)->name,
5483 CELL_NIL,
5484 (SYMBOL*)list->contents,
5485 TRUE))->contents;
5486
5487 /* slice */
5488 if(isNumber(list->type))
5489 {
5490 getIntegerExt(list, (UINT*)&len, FALSE);
5491 list = evaluateExpression(params->next);
5492
5493 if(list->type == CELL_CONTEXT)
5494 list = (CELL *)(translateCreateSymbol(
5495 ((SYMBOL*)list->contents)->name,
5496 CELL_NIL,
5497 (SYMBOL*)list->contents,
5498 TRUE))->contents;
5499
5500 if(isList(list->type))
5501 return(sublist((CELL *)list->contents, n, len));
5502 else if(list->type == CELL_STRING)
5503 return(substring((char *)list->contents, list->aux-1, n, len));
5504 else if(list->type == CELL_ARRAY)
5505 return(subarray(list, n, len));
5506 }
5507
5508 /* nrest lists */
5509 else if(isList(list->type))
5510 {
5511 list = (CELL *)list->contents;
5512
5513 if(n < 0) n = convertNegativeOffset(n, list);
5514
5515 while(n-- && list != nilCell)
5516 list = list->next;
5517
5518 return(makeCell(CELL_EXPRESSION, (UINT)copyList(list)));
5519 }
5520
5521 /* nrest strings
5522 this was UTF-8 sensitive before 9.1.11, but only the
5523 explicit first/last/rest should be UTF8-sensitive
5524 */
5525 else if(list->type == CELL_STRING)
5526 return(substring((char *)list->contents, list->aux - 1, n, MAX_LONG));
5527
5528 else if(list->type == CELL_ARRAY)
5529 return(subarray(list, n, MAX_LONG));
5530
5531 return(errorProcExt(ERR_ILLEGAL_TYPE, params));
5532 }
5533
5534
p_cons(CELL * params)5535 CELL * p_cons(CELL * params)
5536 {
5537 CELL * cons;
5538 CELL * head;
5539 CELL * tail;
5540
5541 if(params == nilCell)
5542 return(getCell(CELL_EXPRESSION));
5543
5544 head = copyCell(evaluateExpression(params));
5545 cons = makeCell(CELL_EXPRESSION, (UINT)head);
5546 params = params->next;
5547
5548 if(params != nilCell)
5549 {
5550 tail = evaluateExpression(params);
5551
5552 if(isList(tail->type))
5553 {
5554 head->next = copyList((CELL *)tail->contents);
5555 cons->type = tail->type;
5556 }
5557 else
5558 head->next = copyCell(tail);
5559 }
5560
5561 return(cons);
5562 }
5563
5564
p_list(CELL * params)5565 CELL * p_list(CELL * params)
5566 {
5567 CELL * list;
5568 CELL * lastCopy = NULL;
5569 CELL * copy;
5570 CELL * cell;
5571 UINT * resultIdxSave;
5572
5573 list = getCell(CELL_EXPRESSION);
5574
5575 resultIdxSave = resultStackIdx;
5576 while(params != nilCell)
5577 {
5578 cell = evaluateExpression(params);
5579 if(cell->type == CELL_ARRAY)
5580 copy = arrayList(cell, TRUE);
5581 else
5582 copy = copyCell(cell);
5583 if(lastCopy == NULL)
5584 list->contents = (UINT)copy;
5585 else lastCopy->next = copy;
5586 lastCopy = copy;
5587 cleanupResults(resultIdxSave);
5588 params = params->next;
5589 }
5590
5591 return(list);
5592 }
5593
5594
p_last(CELL * params)5595 CELL * p_last(CELL * params)
5596 {
5597 CELL * cell;
5598 CELL * listPtr;
5599 CELL * result;
5600 char * str;
5601
5602 getEvalDefault(params, &cell);
5603
5604 if(cell->type == CELL_STRING)
5605 {
5606 stringCell = cell;
5607 str = (char *)cell->contents;
5608 if(*str == 0) return(copyCell(cell));
5609 #ifndef SUPPORT_UTF8
5610 str += (cell->aux - 2);
5611 result = stuffString(str);
5612 #else
5613 str = utf8_index(str, utf8_wlen(str, str + cell->aux) -1);
5614 result = stuffString(str);
5615 #endif
5616 stringIndexPtr = (char *)str;
5617 if(symbolCheck)
5618 {
5619 pushResult(result);
5620 pushResultFlag = FALSE;
5621 }
5622 return(result);
5623 }
5624
5625 else if(isList(cell->type))
5626 {
5627 if(cell->contents == (UINT)nilCell)
5628 return(errorProcExt(ERR_LIST_EMPTY, params));
5629
5630 if(cell->aux != (UINT)nilCell)
5631 {
5632 pushResultFlag = FALSE;
5633 return((CELL *)cell->aux);
5634 }
5635
5636 listPtr = (CELL *)cell->contents;
5637 while(listPtr->next != nilCell) listPtr = listPtr->next;
5638 cell->aux = (UINT)listPtr;
5639 pushResultFlag = FALSE;
5640 return(listPtr);
5641 }
5642
5643 else if(cell->type == CELL_ARRAY)
5644 {
5645 pushResultFlag = FALSE;
5646 return(*((CELL * *)cell->contents + (cell->aux - 1) / sizeof(UINT) - 1));
5647 }
5648
5649 return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, params));
5650 }
5651
5652
5653 /* -------------------------- program flow and logical ------------------ */
5654
evaluateBlock(CELL * cell)5655 CELL * evaluateBlock(CELL * cell)
5656 {
5657 CELL * result;
5658
5659 result = nilCell;
5660
5661 while(cell != nilCell)
5662 {
5663 result = evaluateExpression(cell);
5664 cell = cell->next;
5665 }
5666 return(result);
5667 }
5668
5669
p_if(CELL * params)5670 CELL * p_if(CELL * params)
5671 {
5672 CELL * cell;
5673
5674 cell = evaluateExpression(params);
5675 itSymbol->contents = (UINT)cell;
5676 while(isNil(cell) || isEmpty(cell))
5677 {
5678 params = params->next;
5679 if(params->next == nilCell)
5680 goto IF_RETURN;
5681 params = params->next;
5682 cell = evaluateExpression(params);
5683 }
5684
5685 if(params->next != nilCell)
5686 cell = evaluateExpression(params->next);
5687
5688 IF_RETURN:
5689 itSymbol->contents = (UINT)nilCell;
5690 pushResultFlag = FALSE;
5691 return(cell);
5692 }
5693
5694
p_ifNot(CELL * params)5695 CELL * p_ifNot(CELL * params)
5696 {
5697 CELL * cell;
5698
5699 cell = evaluateExpression(params);
5700 if(!isNil(cell) && !isEmpty(cell))
5701 params = params->next;
5702
5703 cell = evaluateExpression(params->next);
5704
5705 pushResultFlag = FALSE;
5706 return(cell);
5707 }
5708
5709
p_when(CELL * params)5710 CELL * p_when(CELL * params)
5711 {
5712 CELL * cell;
5713
5714 cell = evaluateExpression(params);
5715 if(isNil(cell) || isEmpty(cell)) goto WHEN_END;
5716
5717 while((params = params->next) != nilCell)
5718 cell = evaluateExpression(params);
5719
5720 WHEN_END:
5721 pushResultFlag = FALSE;
5722 return(cell);
5723 }
5724
p_unless(CELL * params)5725 CELL * p_unless(CELL * params)
5726 {
5727 CELL * cell;
5728
5729 cell = evaluateExpression(params);
5730 if(!isNil(cell) && !isEmpty(cell)) goto UNLESS_END;
5731
5732 while((params = params->next) != nilCell)
5733 cell = evaluateExpression(params);
5734
5735 UNLESS_END:
5736 pushResultFlag = FALSE;
5737 return(cell);
5738 }
5739
5740
p_condition(CELL * params)5741 CELL * p_condition(CELL * params)
5742 {
5743 CELL * condition;
5744 CELL * eval = nilCell;
5745
5746 while(params != nilCell)
5747 {
5748 if(params->type == CELL_EXPRESSION)
5749 {
5750 condition = (CELL *)params->contents;
5751 eval = evaluateExpression(condition);
5752 if(!isNil(eval) && !isEmpty(eval))
5753 {
5754 if(condition->next != nilCell)
5755 eval = evaluateBlock(condition->next);
5756 break;
5757 }
5758 params = params->next;
5759 }
5760 else return(errorProc(ERR_LIST_EXPECTED));
5761 }
5762
5763 pushResultFlag = FALSE;
5764 return(eval);
5765 }
5766
5767
p_case(CELL * params)5768 CELL * p_case(CELL * params)
5769 {
5770 CELL * cases;
5771 CELL * cond;
5772 CELL * eval;
5773
5774 cases = params->next;
5775 params = evaluateExpression(params);
5776 while(cases != nilCell)
5777 {
5778 if(cases->type == CELL_EXPRESSION)
5779 {
5780 cond = (CELL *)cases->contents;
5781 if(compareCells(params, cond) == 0
5782 || (cond->type == CELL_SYMBOL && symbolType((SYMBOL *)cond->contents) == CELL_TRUE)
5783 || cond->type == CELL_TRUE)
5784 {
5785 eval = evaluateBlock(cond->next);
5786 pushResultFlag = FALSE;
5787 return(eval);
5788 }
5789 }
5790 cases = cases->next;
5791 }
5792
5793 return(nilCell);
5794 }
5795
5796 #define REPEAT_WHILE 0
5797 #define REPEAT_DOWHILE 1
5798 #define REPEAT_UNTIL 2
5799 #define REPEAT_DOUNTIL 3
5800
p_while(CELL * params)5801 CELL * p_while(CELL * params) { return(repeat(params, REPEAT_WHILE)); }
p_doWhile(CELL * params)5802 CELL * p_doWhile(CELL * params) { return(repeat(params, REPEAT_DOWHILE)); }
p_until(CELL * params)5803 CELL * p_until(CELL * params) { return(repeat(params, REPEAT_UNTIL)); }
p_doUntil(CELL * params)5804 CELL * p_doUntil(CELL * params) { return(repeat(params, REPEAT_DOUNTIL)); }
5805
5806
repeat(CELL * params,int type)5807 CELL * repeat(CELL * params, int type)
5808 {
5809 CELL * result;
5810 CELL * cell;
5811 CELL * cellIdx;
5812 UINT * resultIdxSave;
5813 SYMBOL * symbolRef = NULL;
5814
5815 cellIdx = initIteratorIndex();
5816
5817 resultIdxSave = resultStackIdx;
5818 result = nilCell;
5819 while(TRUE)
5820 {
5821 switch(type)
5822 {
5823 case REPEAT_WHILE:
5824 cell = evaluateExpression(params);
5825 if(isNil(cell) || isEmpty(cell)) goto END_REPEAT;
5826 cleanupResults(resultIdxSave);
5827 result = evaluateBlock(params->next);
5828 symbolRef = symbolCheck;
5829 break;
5830 case REPEAT_DOWHILE:
5831 result = evaluateBlock(params->next);
5832 symbolRef = symbolCheck;
5833 cell = evaluateExpression(params);
5834 if(isNil(cell) || isEmpty(cell)) goto END_REPEAT;
5835 cleanupResults(resultIdxSave);
5836 break;
5837 case REPEAT_UNTIL:
5838 cell = evaluateExpression(params);
5839 if(!isNil(cell) && !isEmpty(cell))
5840 {
5841 if(params->next == nilCell)
5842 result = cell;
5843 goto END_REPEAT;
5844 }
5845 cleanupResults(resultIdxSave);
5846 result = evaluateBlock(params->next);
5847 symbolRef = symbolCheck;
5848 break;
5849 case REPEAT_DOUNTIL:
5850 result = evaluateBlock(params->next);
5851 symbolRef = symbolCheck;
5852 cell = evaluateExpression(params);
5853 if(!isNil(cell) && !isEmpty(cell))
5854 {
5855 if(params->next == nilCell)
5856 result = cell;
5857 goto END_REPEAT;
5858 }
5859 cleanupResults(resultIdxSave);
5860 break;
5861 default:
5862 break;
5863 }
5864
5865 if(cellIdx->type == CELL_LONG) cellIdx->contents += 1;
5866 }
5867
5868 END_REPEAT:
5869 recoverIteratorIndex(cellIdx);
5870
5871 symbolCheck = symbolRef;
5872 pushResultFlag = FALSE;
5873 return(result);
5874 }
5875
5876
getPushSymbolParam(CELL * params,SYMBOL ** sym)5877 CELL * getPushSymbolParam(CELL * params, SYMBOL * * sym)
5878 {
5879 SYMBOL * symbol;
5880 CELL * cell;
5881
5882 if(params->type != CELL_EXPRESSION)
5883 return(errorProcExt(ERR_LIST_EXPECTED, params));
5884
5885 cell = (CELL *)params->contents;
5886 if(cell->type != CELL_SYMBOL)
5887 return(errorProcExt(ERR_SYMBOL_EXPECTED, cell));
5888
5889 *sym = symbol = (SYMBOL *)cell->contents;
5890 if(isProtected(symbol->flags))
5891 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
5892
5893 pushEnvironment((CELL *)symbol->contents);
5894 pushEnvironment((UINT)symbol);
5895 symbol->contents = (UINT)nilCell;
5896
5897 return(cell->next);
5898 }
5899
5900
initIteratorIndex(void)5901 CELL * initIteratorIndex(void)
5902 {
5903 CELL * cell = stuffInteger(0);
5904
5905 pushEnvironment(listIdxSymbol->contents);
5906 pushEnvironment(listIdxSymbol);
5907 listIdxSymbol->contents = (UINT)cell;
5908
5909 return(cell);
5910 }
5911
recoverIteratorIndex(CELL * cellIdx)5912 void recoverIteratorIndex(CELL * cellIdx)
5913 {
5914 deleteList(cellIdx);
5915 listIdxSymbol = (SYMBOL*)popEnvironment();
5916 listIdxSymbol->contents = (UINT)popEnvironment();
5917 }
5918
loop(CELL * params,int forFlag)5919 CELL * loop(CELL * params, int forFlag)
5920 {
5921 CELL * cell;
5922 CELL * cond = nilCell;
5923 CELL * block;
5924 SYMBOL * symbol = NULL;
5925 double fromFlt, toFlt, interval, step, cntFlt;
5926 INT64 stepCnt, i;
5927 INT64 fromInt64 = 0, toInt64 = 0;
5928 int intFlag;
5929 UINT * resultIdxSave;
5930
5931 cell = getPushSymbolParam(params, &symbol);
5932
5933 /* integer loops for dotimes and (for (i from to) ...) */
5934 if((intFlag = ((CELL *)cell->next)->next == nilCell))
5935 {
5936 if(forFlag)
5937 {
5938 cell = getInteger64Ext(cell, &fromInt64, TRUE);
5939 getInteger64Ext(cell, &toInt64, TRUE);
5940 stepCnt = (toInt64 > fromInt64) ? toInt64 - fromInt64 : fromInt64 - toInt64;
5941 }
5942 else /* dotimes */
5943 {
5944 fromInt64 = toInt64 = 0;
5945 cond = getInteger64Ext(cell, &stepCnt, TRUE);
5946 }
5947 }
5948 else /* float (for (i from to step) ...) */
5949 {
5950 cell = getFloat(cell, &fromFlt);
5951 cell = getFloat(cell, &toFlt);
5952 cond = getFloat(cell, &step);
5953 if(isnan(fromFlt) || isnan(toFlt) || isnan(step))
5954 return(errorProc(ERR_INVALID_PARAMETER_NAN));
5955 if(step < 0) step = -step;
5956 if(fromFlt > toFlt) step = -step;
5957 cntFlt = (fromFlt < toFlt) ? (toFlt - fromFlt)/step : (fromFlt - toFlt)/step;
5958 stepCnt = (cntFlt > 0.0) ? floor(cntFlt + 0.0000000001) : floor(-cntFlt + 0.0000000001);
5959 }
5960
5961 block = params->next;
5962 resultIdxSave = resultStackIdx;
5963 cell = nilCell;
5964 for(i = 0; i <= stepCnt; i++)
5965 {
5966 if(!forFlag && i == stepCnt) break;
5967 deleteList((CELL *)symbol->contents);
5968 if(intFlag)
5969 {
5970 symbol->contents =
5971 (UINT)stuffInteger64((fromInt64 > toInt64) ? fromInt64 - i:
5972 fromInt64 + i);
5973 }
5974 else
5975 {
5976 interval = fromFlt + i * step;
5977 symbol->contents = (UINT)stuffFloat(interval);
5978 }
5979 /* cleanupResults(resultIdxSave);*/
5980 while(resultStackIdx > resultIdxSave) deleteList(popResult());
5981 if(cond != nilCell)
5982 {
5983 cell = evaluateExpression(cond);
5984 if(!isNil(cell)) break;
5985 }
5986 cell = evaluateBlock(block);
5987 }
5988
5989
5990 if(symbolCheck && cell != (CELL *)symbol->contents && symbol != symbolCheck)
5991 pushResultFlag = FALSE;
5992 else
5993 cell = copyCell(cell);
5994
5995 deleteList((CELL *)symbol->contents);
5996 symbol = (SYMBOL*)popEnvironment();
5997 symbol->flags &= ~SYMBOL_PROTECTED;
5998 symbol->contents = (UINT)popEnvironment();
5999
6000 return(cell);
6001 }
6002
6003
p_dotimes(CELL * params)6004 CELL * p_dotimes(CELL * params)
6005 {
6006 return(loop(params, 0));
6007 }
6008
p_for(CELL * params)6009 CELL * p_for(CELL * params)
6010 {
6011 return(loop(params, 1));
6012 }
6013
6014
6015 #define DOLIST 0
6016 #define DOTREE 1
6017 #define DOARGS 2
6018 #define DOSTRING 3
6019
p_dolist(CELL * params)6020 CELL * p_dolist(CELL * params)
6021 {
6022 return(dolist(params, DOLIST));
6023 }
6024
p_dotree(CELL * params)6025 CELL * p_dotree(CELL * params)
6026 {
6027 return(dolist(params, DOTREE));
6028 }
6029
p_doargs(CELL * params)6030 CELL * p_doargs(CELL * params)
6031 {
6032 return(dolist(params, DOARGS));
6033 }
6034
p_dostring(CELL * params)6035 CELL * p_dostring(CELL * params)
6036 {
6037 return(dolist(params, DOSTRING));
6038 }
6039
dolist(CELL * params,int doType)6040 CELL * dolist(CELL * params, int doType)
6041 {
6042 CELL * cell;
6043 CELL * list = nilCell;
6044 char * str;
6045 #ifdef SUPPORT_UTF8
6046 int chr;
6047 #endif
6048 CELL * cond = nilCell;
6049 SYMBOL * symbol = NULL;
6050 SYMBOL * sPtr;
6051 CELL * cellIdx;
6052 UINT * resultIdxSave;
6053
6054 cell = getPushSymbolParam(params, &symbol);
6055 cellIdx = initIteratorIndex();
6056
6057 switch(doType)
6058 {
6059 case DOLIST:
6060 /* list = copyCell(evaluateExpression(cell)); */
6061 getEvalDefault(cell, &list);
6062 if(isList(list->type)) list = copyCell(list);
6063 else if(list->type == CELL_ARRAY) list = arrayList(list, FALSE);
6064 else return(errorProcExt(ERR_LIST_EXPECTED, cell));
6065 cond = cell->next;
6066 break;
6067 case DOTREE:
6068 getContext(cell, &sPtr);
6069 list = getCell(CELL_EXPRESSION);
6070 collectSymbols((SYMBOL *)((CELL *)sPtr->contents)->aux, list);
6071 cond = (getFlag(cell->next) == 1) ? trueCell : nilCell;
6072 break;
6073 case DOARGS:
6074 list = copyCell((CELL *)argsSymbol->contents);
6075 cond = cell;
6076 break;
6077 case DOSTRING:
6078 getString(cell, &str);
6079 resultIdxSave = resultStackIdx;
6080 cond = cell->next;
6081 while(*str)
6082 {
6083 cleanupResults(resultIdxSave);
6084 deleteList((CELL *)symbol->contents);
6085 #ifdef SUPPORT_UTF8
6086 str = utf8_wchar(str, &chr);
6087 symbol->contents = (UINT)stuffInteger(chr);
6088 #else
6089 symbol->contents = (UINT)stuffInteger((int)*str++);
6090 #endif
6091 if(cond != nilCell)
6092 {
6093 cell = evaluateExpression(cond);
6094 if(!isNil(cell)) break;
6095 }
6096 cell = evaluateBlock(params->next);
6097 if(cellIdx->type == CELL_LONG) cellIdx->contents += 1;
6098 }
6099 goto FINISH_DO;
6100 break;
6101 }
6102
6103 /* make sure worklist gets destroyed */
6104 pushResult(list);
6105 list = (CELL *)list->contents;
6106
6107 resultIdxSave = resultStackIdx;
6108 cell = nilCell;
6109 while(list!= nilCell)
6110 {
6111 cleanupResults(resultIdxSave);
6112 deleteList((CELL *)symbol->contents);
6113 symbol->contents = (UINT)copyCell(list);
6114 if(cond != nilCell)
6115 {
6116 if(doType == DOTREE)
6117 {
6118 sPtr = (SYMBOL *)list->contents;
6119 if(*sPtr->name != '_')
6120 {
6121 cell = nilCell;
6122 goto DO_CONTINUE;
6123 }
6124 }
6125 else
6126 {
6127 cell = evaluateExpression(cond);
6128 if(!isNil(cell)) break;
6129 }
6130 }
6131 cell = evaluateBlock(params->next);
6132 if(cellIdx->type == CELL_LONG) cellIdx->contents += 1;
6133 DO_CONTINUE:
6134 list = list->next;
6135 }
6136
6137 FINISH_DO:
6138 if(symbolCheck && cell != (CELL *)symbol->contents && symbol != symbolCheck)
6139 pushResultFlag = FALSE;
6140 else
6141 cell = copyCell(cell);
6142
6143 recoverIteratorIndex(cellIdx);
6144
6145 deleteList((CELL *)symbol->contents);
6146 symbol = (SYMBOL*)popEnvironment();
6147 symbol->contents = (UINT)popEnvironment();
6148
6149 return(cell);
6150 }
6151
6152
p_evalBlock(CELL * params)6153 CELL * p_evalBlock(CELL * params)
6154 {
6155 CELL * result = nilCell;
6156
6157 while(params != nilCell)
6158 {
6159 result = evaluateExpression(params);
6160 params = params->next;
6161 }
6162
6163 pushResultFlag = FALSE;
6164 return(result);
6165 }
6166
6167 extern UINT getAddress(CELL * params);
6168
p_copy(CELL * params)6169 CELL * p_copy(CELL * params)
6170 {
6171 CELL * copy;
6172
6173 /* experimental: copy a cell from address, from:
6174 http://www.newlispfanclub.alh.net/forum/viewtopic.php?f=5&t=4548
6175 June 14, 2014 "get-cell function patch"
6176 */
6177 if(params->next != nilCell && getFlag(params->next))
6178 return(copyCell((CELL *)getAddress(params)));
6179
6180 copy = copyCell(evaluateExpression(params));
6181 symbolCheck = NULL;
6182 return(copy);
6183 }
6184
p_silent(CELL * params)6185 CELL * p_silent(CELL * params)
6186 {
6187 CELL * cell;
6188 evalSilent = TRUE;
6189
6190 cell = evaluateBlock(params);
6191 if(symbolCheck)
6192 {
6193 pushResultFlag = FALSE;
6194 return(cell);
6195 }
6196
6197 return(copyCell(cell));
6198 }
6199
6200
p_and(CELL * params)6201 CELL * p_and(CELL * params)
6202 {
6203 CELL * result = trueCell;
6204
6205 while(params != nilCell)
6206 {
6207 result = evaluateExpression(params);
6208 if(isNil(result) || isEmpty(result)) return(copyCell(result));
6209 params = params->next;
6210 }
6211
6212 if(symbolCheck)
6213 {
6214 pushResultFlag = FALSE;
6215 return(result);
6216 }
6217
6218 return(copyCell(result));
6219 }
6220
6221
p_or(CELL * params)6222 CELL * p_or(CELL * params)
6223 {
6224 CELL * result = nilCell;
6225
6226 while(params != nilCell)
6227 {
6228 result = evaluateExpression(params);
6229 if(!isNil(result) && !isEmpty(result))
6230 {
6231 if(symbolCheck)
6232 {
6233 pushResultFlag = FALSE;
6234 return(result);
6235 }
6236 return(copyCell(result));
6237 }
6238 params = params->next;
6239 }
6240
6241 return(copyCell(result));
6242 }
6243
6244
p_not(CELL * params)6245 CELL * p_not(CELL * params)
6246 {
6247 CELL * eval;
6248
6249 eval = evaluateExpression(params);
6250 if(isNil(eval) || isEmpty(eval))
6251 return(trueCell);
6252 return(nilCell);
6253 }
6254
6255
6256
6257 /* ------------------------------ I / O --------------------------------- */
6258
p_print(CELL * params)6259 CELL * p_print(CELL * params)
6260 {
6261 return println(params, FALSE);
6262 }
6263
6264
p_println(CELL * params)6265 CELL * p_println(CELL * params)
6266 {
6267 return println(params, TRUE);
6268 }
6269
6270
println(CELL * params,int lineFeed)6271 CELL * println(CELL * params, int lineFeed)
6272 {
6273 CELL * result;
6274
6275 result = nilCell;
6276 while(params != nilCell)
6277 {
6278 result = evaluateExpression(params);
6279 printCell(result, 0, OUT_DEVICE);
6280 params = params->next;
6281 }
6282
6283 if(lineFeed) varPrintf(OUT_DEVICE, LINE_FEED);
6284
6285 return(copyCell(result));
6286 }
6287
6288
p_device(CELL * params)6289 CELL * p_device(CELL * params)
6290 {
6291 if(params != nilCell)
6292 getInteger(params, &printDevice);
6293 return(stuffInteger(printDevice));
6294 }
6295
6296
p_load(CELL * params)6297 CELL * p_load(CELL * params)
6298 {
6299 char * fileName;
6300 CELL * result = nilCell;
6301 CELL * next;
6302 SYMBOL * context;
6303 int count = 0;
6304
6305 /* get last parameter */
6306 if((next = params) == nilCell)
6307 errorProc(ERR_MISSING_ARGUMENT);
6308 while(next->next != nilCell)
6309 {
6310 count++;
6311 next = next->next;
6312 }
6313
6314 next = evaluateExpression(next);
6315 if(next->type == CELL_STRING)
6316 {
6317 count++;
6318 context = mainContext;
6319 }
6320 else
6321 {
6322 if(count == 0)
6323 errorProcExt(ERR_STRING_EXPECTED, next);
6324 if((context = getCreateContext(next, FALSE)) == NULL)
6325 errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, next);
6326 next = NULL;
6327 }
6328
6329 while(count--)
6330 {
6331 /* if last arg was a string, avoid double evaluation */
6332 if(count == 0 && next != NULL)
6333 getStringSize(next, &fileName, NULL, FALSE);
6334 else
6335 params = getString(params, &fileName);
6336
6337 result = loadFile(fileName, 0, 0, context);
6338
6339 if(result == NULL)
6340 return(errorProcExt2(ERR_ACCESSING_FILE, stuffString(fileName)));
6341 }
6342
6343 return(result);
6344 }
6345
6346
saveContext(SYMBOL * sPtr,UINT device)6347 void saveContext(SYMBOL * sPtr, UINT device)
6348 {
6349 SYMBOL * contextSave;
6350
6351 contextSave = currentContext;
6352
6353 currentContext = sPtr;
6354
6355 if(currentContext != mainContext)
6356 {
6357 varPrintf(device, "%s(context '%s)%s%s",
6358 LINE_FEED, sPtr->name, LINE_FEED, LINE_FEED);
6359 /* make sure 'set' is not overwritten */
6360 if((sPtr = lookupSymbol("set", currentContext)) != NULL)
6361 {
6362 deleteList((CELL *)sPtr->contents);
6363 sPtr->contents = (UINT)copyCell(nilCell);
6364 }
6365 }
6366
6367
6368 saveSymbols((SYMBOL *)((CELL*)currentContext->contents)->aux, device);
6369
6370 if(currentContext != mainContext)
6371 varPrintf(device, "%s(context MAIN)%s%s",
6372 LINE_FEED, LINE_FEED, LINE_FEED);
6373
6374 currentContext = contextSave;
6375 }
6376
6377
saveSymbols(SYMBOL * sPtr,UINT device)6378 void saveSymbols(SYMBOL * sPtr, UINT device)
6379 {
6380 int type;
6381
6382 if(sPtr != NIL_SYM && sPtr != NULL)
6383 {
6384 saveSymbols(sPtr->left, device);
6385 type = symbolType(sPtr);
6386 if(type == CELL_CONTEXT)
6387 {
6388 if(sPtr == (SYMBOL *)((CELL *)sPtr->contents)->contents)
6389 {
6390 if(sPtr != currentContext && *sPtr->name != '$') saveContext(sPtr, device);
6391 }
6392 else printSymbol(sPtr, device);
6393 }
6394 /* don't save primitives, symbols containing nil and the trueSymbol */
6395 else if(type != CELL_PRIMITIVE && type != CELL_NIL
6396 && sPtr != trueSymbol && type != CELL_IMPORT_CDECL && type != CELL_IMPORT_FFI
6397 #if defined(WINDOWS) || defined(CYGWIN)
6398 && type != CELL_IMPORT_DLL
6399 #endif
6400 )
6401 if(*sPtr->name != '$') printSymbol(sPtr, device);
6402 saveSymbols(sPtr->right, device);
6403 }
6404 }
6405
6406
p_save(CELL * params)6407 CELL * p_save(CELL * params)
6408 {
6409 char * fileName;
6410 STREAM strStream = {NULL, NULL, 0, 0, 0};
6411 SYMBOL * contextSave;
6412 #ifndef EMSCRIPTEN
6413 CELL * result;
6414 CELL * dataCell;
6415 #endif
6416 int errorFlag = 0;
6417
6418 contextSave = currentContext;
6419 currentContext = mainContext;
6420
6421 params = getString(params, &fileName);
6422
6423 openStrStream(&strStream, MAX_STRING, 0);
6424 serializeSymbols(params, (UINT)&strStream);
6425
6426 #ifndef EMSCRIPTEN
6427 /* check for URL format */
6428 if(my_strnicmp(fileName, "http://", 7) == 0)
6429 {
6430 dataCell = stuffString(strStream.buffer);
6431 result = getPutPostDeleteUrl(fileName, dataCell, HTTP_PUT, CONNECT_TIMEOUT);
6432 pushResult(result);
6433 deleteList(dataCell);
6434 errorFlag = (strncmp((char *)result->contents, "ERR:", 4) == 0);
6435 }
6436 else
6437 #endif
6438 errorFlag = writeFile(fileName, strStream.buffer, strStream.position, "w");
6439
6440 closeStrStream(&strStream);
6441
6442 currentContext = contextSave;
6443
6444 if(errorFlag)
6445 return(errorProcExt2(ERR_SAVING_FILE, stuffString(fileName)));
6446
6447 return(trueCell);
6448 }
6449
serializeSymbols(CELL * params,UINT device)6450 void serializeSymbols(CELL * params, UINT device)
6451 {
6452 SYMBOL * sPtr;
6453
6454 if(params->type == CELL_NIL)
6455 saveSymbols((SYMBOL *)((CELL*)currentContext->contents)->aux, device);
6456 else
6457 while(params != nilCell)
6458 {
6459 params = getSymbol(params, &sPtr);
6460 if(symbolType(sPtr) == CELL_CONTEXT)
6461 saveContext((SYMBOL*)((CELL *)sPtr->contents)->contents, device);
6462 else
6463 printSymbol(sPtr, device);
6464 }
6465 }
6466
6467 /* ----------------------- copy a context with 'new' -------------- */
6468 static SYMBOL * fromContext;
6469 static SYMBOL * toContext;
6470 static int overWriteFlag;
6471
6472 CELL * copyContextList(CELL * cell);
6473 UINT * copyContextArray(CELL * array);
6474
6475
copyContextCell(CELL * cell)6476 CELL * copyContextCell(CELL * cell)
6477 {
6478 CELL * newCell;
6479 SYMBOL * sPtr;
6480 SYMBOL * newSptr;
6481
6482 if(firstFreeCell == NULL) allocBlock();
6483 newCell = firstFreeCell;
6484 firstFreeCell = newCell->next;
6485 ++cellCount;
6486
6487 newCell->type = cell->type;
6488 newCell->next = nilCell;
6489 newCell->aux = cell->aux;
6490 newCell->contents = cell->contents;
6491
6492 if(cell->type == CELL_DYN_SYMBOL)
6493 {
6494 sPtr = (SYMBOL*)cell->aux;
6495 if(sPtr->context == fromContext)
6496 newCell->aux =
6497 (UINT)translateCreateSymbol(sPtr->name, 0, toContext, TRUE);
6498 newCell->contents = (UINT)allocMemory(strlen((char *)cell->contents) + 1);
6499 memcpy((void *)newCell->contents,
6500 (void*)cell->contents, strlen((char *)cell->contents) + 1);
6501 }
6502
6503 if(cell->type == CELL_SYMBOL)
6504 {
6505 /* if the cell copied, itself contains a symbol copy it recursevely,
6506 if new, if not done here it might not been seen as new later and left
6507 without contents */
6508 sPtr = (SYMBOL *)cell->contents;
6509 /* don't copy symbols of builtins and libffi */
6510 if(sPtr->context == fromContext && !(sPtr->flags & (SYMBOL_BUILTIN | SYMBOL_FFI)))
6511 {
6512 if((newSptr = lookupSymbol(sPtr->name, toContext)) == NULL)
6513 {
6514 newSptr = translateCreateSymbol(sPtr->name, symbolType(sPtr), toContext, TRUE);
6515 deleteList((CELL *)newSptr->contents);
6516 newSptr->contents = (UINT)copyContextCell((CELL*)sPtr->contents);
6517 }
6518 newCell->contents = (UINT)newSptr;
6519 newSptr->flags = sPtr->flags;
6520 }
6521 }
6522
6523 if(isEnvelope(cell->type))
6524 {
6525 if(cell->type == CELL_ARRAY)
6526 newCell->contents = (UINT)copyContextArray(cell);
6527 else
6528 {
6529 /* undo push last optimization */
6530 newCell->aux = (UINT)nilCell;
6531 newCell->contents = (UINT)copyContextList((CELL *)cell->contents);
6532 }
6533 }
6534 else if(cell->type == CELL_STRING)
6535 {
6536 newCell->contents = (UINT)allocMemory((UINT)cell->aux);
6537 memcpy((void *)newCell->contents, (void*)cell->contents, (UINT)cell->aux);
6538 }
6539
6540 return(newCell);
6541 }
6542
6543
copyContextList(CELL * cell)6544 CELL * copyContextList(CELL * cell)
6545 {
6546 CELL * firstCell;
6547 CELL * newCell;
6548
6549 if(cell == nilCell || cell == trueCell) return(cell);
6550
6551 firstCell = newCell = copyContextCell(cell);
6552
6553 while((cell = cell->next) != nilCell)
6554 {
6555 newCell->next = copyContextCell(cell);
6556 newCell = newCell->next;
6557 }
6558
6559 return(firstCell);
6560 }
6561
6562
copyContextArray(CELL * array)6563 UINT * copyContextArray(CELL * array)
6564 {
6565 CELL * * newAddr;
6566 CELL * * orgAddr;
6567 CELL * * addr;
6568 size_t size;
6569
6570 addr = newAddr = (CELL * *)callocMemory(array->aux);
6571
6572 size = (array->aux - 1) / sizeof(UINT);
6573 orgAddr = (CELL * *)array->contents;
6574
6575 while(size--)
6576 *(newAddr++) = copyContextCell(*(orgAddr++));
6577
6578 return((UINT*)addr);
6579 }
6580
6581
iterateCopyCreateSymbols(SYMBOL * sPtr)6582 void iterateCopyCreateSymbols(SYMBOL * sPtr)
6583 {
6584 int type, newFlag = FALSE;
6585 SYMBOL * newPtr = NULL;
6586
6587 if(sPtr != NIL_SYM && sPtr != NULL && !(sPtr->flags & SYMBOL_BUILTIN))
6588 {
6589 iterateCopyCreateSymbols(sPtr->left);
6590 type = symbolType(sPtr);
6591
6592 /* optimized check for default symbol, translate default symbol to default symbol */
6593 if(*sPtr->name == *fromContext->name && strcmp(sPtr->name, fromContext->name) == 0)
6594 {
6595 if((newPtr = lookupSymbol(toContext->name, toContext)) == NULL)
6596 {
6597 newPtr = translateCreateSymbol(toContext->name, type, toContext, TRUE);
6598 newFlag = TRUE;
6599 }
6600 }
6601 else
6602 {
6603 if((newPtr = lookupSymbol(sPtr->name, toContext)) == NULL)
6604 {
6605 newPtr = translateCreateSymbol(sPtr->name, type, toContext, TRUE);
6606 newFlag = TRUE;
6607 }
6608 }
6609
6610 if(overWriteFlag == TRUE || newFlag == TRUE)
6611 {
6612 deleteList((CELL *)newPtr->contents);
6613 newPtr->contents = (UINT)copyContextCell((CELL*)sPtr->contents);
6614 }
6615
6616 newPtr->flags |= sPtr->flags & SYMBOL_PROTECTED;
6617 iterateCopyCreateSymbols(sPtr->right);
6618 }
6619 }
6620
6621
6622
p_new(CELL * params)6623 CELL * p_new(CELL * params)
6624 {
6625 CELL * next;
6626
6627 overWriteFlag = FALSE;
6628
6629 params = getContext(params, &fromContext);
6630 if(!fromContext) return(nilCell); /* for debug mode */
6631
6632 next = params->next;
6633
6634 if(params == nilCell)
6635 toContext = currentContext;
6636 else
6637 {
6638 params = evaluateExpression(params);
6639 if(params->type == CELL_CONTEXT || params->type == CELL_SYMBOL)
6640 toContext = (SYMBOL *)params->contents;
6641 else
6642 return(errorProcExt(ERR_CONTEXT_EXPECTED, params));
6643
6644 overWriteFlag = (evaluateExpression(next)->type != CELL_NIL);
6645
6646 /* allow symbols to be converted to contexts */
6647 if(symbolType(toContext) != CELL_CONTEXT)
6648 {
6649 if(isProtected(toContext->flags))
6650 return(errorProcExt(ERR_SYMBOL_PROTECTED, params));
6651
6652 if(toContext->context != mainContext)
6653 return(errorProcExt2(ERR_NOT_IN_MAIN, stuffSymbol(toContext)));
6654
6655 deleteList((CELL *)toContext->contents);
6656 makeContextFromSymbol(toContext, NULL);
6657 }
6658 }
6659
6660 if(toContext == mainContext)
6661 return(errorProc(ERR_TARGET_NO_MAIN));
6662
6663 iterateCopyCreateSymbols((SYMBOL *)((CELL*)fromContext->contents)->aux);
6664
6665 return(copyCell((CELL*)toContext->contents));
6666 }
6667
6668
p_defineNew(CELL * params)6669 CELL * p_defineNew(CELL * params)
6670 {
6671 SYMBOL * sourcePtr;
6672 SYMBOL * targetPtr;
6673 char * name;
6674
6675 params = getSymbol(params, &sourcePtr);
6676 if(params != nilCell)
6677 {
6678 getSymbol(params, &targetPtr);
6679 name = targetPtr->name;
6680 toContext = targetPtr->context;
6681 }
6682 else
6683 {
6684 name = sourcePtr->name;
6685 toContext = currentContext;
6686 }
6687
6688 if(toContext == mainContext)
6689 return(errorProc(ERR_TARGET_NO_MAIN));
6690
6691 fromContext = sourcePtr->context;
6692 targetPtr = translateCreateSymbol(name, symbolType(sourcePtr), toContext, TRUE);
6693
6694 deleteList((CELL *)targetPtr->contents);
6695 targetPtr->contents = (UINT)copyContextCell((CELL*)sourcePtr->contents);
6696
6697 targetPtr->flags = sourcePtr->flags;
6698
6699 return(stuffSymbol(targetPtr));
6700 }
6701
6702
6703
6704 /* ------------------------------ system ------------------------------ */
6705
6706 CELL * isType(CELL *, int);
6707
p_isNil(CELL * params)6708 CELL * p_isNil(CELL * params)
6709 {
6710 params = evaluateExpression(params);
6711
6712 if(isNil(params))
6713 return(trueCell);
6714
6715 return(nilCell);
6716 }
6717
p_isEmpty(CELL * params)6718 CELL * p_isEmpty(CELL * params)
6719 {
6720 CELL * cell;
6721
6722 getEvalDefault(params, &cell);
6723 return(isEmptyFunc(cell));
6724 }
6725
isEmptyFunc(CELL * cell)6726 CELL * isEmptyFunc(CELL * cell)
6727 {
6728 if(cell->type == CELL_STRING)
6729 {
6730 if(*(char*)cell->contents == 0)
6731 return(trueCell);
6732 else return(nilCell);
6733 }
6734
6735 if(!isList(cell->type))
6736 return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, cell));
6737 if(cell->contents == (UINT)nilCell)
6738 return(trueCell);
6739 return(nilCell);
6740 }
6741
isZero(CELL * cell)6742 CELL * isZero(CELL * cell)
6743 {
6744 #ifdef BIGINT
6745 int * numPtr;
6746 #endif
6747
6748 switch(cell->type)
6749 {
6750 #ifndef NEWLISP64
6751 case CELL_INT64:
6752 if(*(INT64 *)&cell->aux == 0)
6753 return(trueCell);
6754 break;
6755 #endif
6756 case CELL_FLOAT:
6757 #ifndef NEWLISP64
6758 if(*(double *)&cell->aux == 0.0)
6759 #else
6760 if(*(double *)&cell->contents == 0.0)
6761 #endif
6762 return(trueCell);
6763 break;
6764 case CELL_LONG:
6765 if(cell->contents == 0)
6766 return(trueCell);
6767 break;
6768 #ifdef BIGINT
6769 case CELL_BIGINT:
6770 numPtr = (int *)(UINT)cell->contents;
6771 if(cell->aux == 2 && numPtr[1] == 0)
6772 return(trueCell);
6773 break;
6774 #endif
6775 default:
6776 break;
6777 }
6778
6779 return(nilCell);
6780 }
6781
6782
p_isNull(CELL * params)6783 CELL * p_isNull(CELL * params)
6784 {
6785 CELL * cell;
6786
6787 cell = evaluateExpression(params);
6788 if(isNil(cell))
6789 return(trueCell);
6790
6791 if( (cell->type == CELL_STRING || isList(cell->type)))
6792 return(isEmptyFunc(cell));
6793
6794 #ifndef NEWLISP64
6795 if(cell->type == CELL_FLOAT && (isnan(*(double *)&cell->aux)) )
6796 #else
6797 if(cell->type == CELL_FLOAT && (isnan(*(double *)&cell->contents)))
6798 #endif
6799 return(trueCell);
6800
6801 return(isZero(cell));
6802 }
6803
p_isZero(CELL * params)6804 CELL * p_isZero(CELL * params)
6805 {
6806 return(isZero(evaluateExpression(params)));
6807 }
6808
6809
p_isTrue(CELL * params)6810 CELL * p_isTrue(CELL * params)
6811 {
6812 params = evaluateExpression(params);
6813 if(!isNil(params) && !isEmpty(params))
6814 return(trueCell);
6815
6816 return(nilCell);
6817 }
6818
p_isInteger(CELL * params)6819 CELL * p_isInteger(CELL * params)
6820 {
6821 params = evaluateExpression(params);
6822 if((params->type & COMPARE_TYPE_MASK) == CELL_INT)
6823 return(trueCell);
6824 return(nilCell);
6825 }
6826
6827 #ifdef BIGINT
p_isBigInteger(CELL * params)6828 CELL * p_isBigInteger(CELL * params)
6829 { return(isType(params, CELL_BIGINT)); }
6830 #endif
6831
p_isFloat(CELL * params)6832 CELL * p_isFloat(CELL * params)
6833 { return(isType(params, CELL_FLOAT)); }
6834
p_isNumber(CELL * params)6835 CELL * p_isNumber(CELL * params)
6836 {
6837 params = evaluateExpression(params);
6838 if(isNumber(params->type)) return(trueCell);
6839 return(nilCell);
6840 }
6841
p_isString(CELL * params)6842 CELL * p_isString(CELL * params)
6843 { return(isType(params, CELL_STRING)); }
6844
p_isSymbol(CELL * params)6845 CELL * p_isSymbol(CELL * params)
6846 { return(isType(params, CELL_SYMBOL)); }
6847
p_isContext(CELL * params)6848 CELL * p_isContext(CELL * params)
6849 {
6850 char * symStr;
6851 SYMBOL * ctx;
6852
6853 /* check type */
6854 if(params->next == nilCell)
6855 return(isType(params, CELL_CONTEXT));
6856
6857 /* check for existense of symbol */
6858 params = getContext(params, &ctx);
6859 if(!ctx) return(nilCell); /* for debug mode */
6860 getString(params, &symStr);
6861
6862 return (lookupSymbol(symStr, ctx) ? trueCell : nilCell);
6863 }
6864
p_isPrimitive(CELL * params)6865 CELL * p_isPrimitive(CELL * params)
6866 { return(isType(params, CELL_PRIMITIVE)); }
6867
6868
p_isGlobal(CELL * params)6869 CELL * p_isGlobal(CELL * params)
6870 {
6871 params = evaluateExpression(params);
6872 if(isSymbol(params->type) && isGlobal(((SYMBOL *)params->contents)->flags))
6873 return(trueCell);
6874 return(nilCell);
6875 }
6876
p_isProtected(CELL * params)6877 CELL * p_isProtected(CELL * params)
6878 {
6879 params = evaluateExpression(params);
6880 if(isSymbol(params->type) && isProtected(((SYMBOL *)params->contents)->flags))
6881 return(trueCell);
6882 return(nilCell);
6883 }
6884
p_isAtom(CELL * params)6885 CELL * p_isAtom(CELL * params)
6886 {
6887 if(params == nilCell)
6888 return(errorProc(ERR_MISSING_ARGUMENT));
6889 params = evaluateExpression(params);
6890 if(params->type & ENVELOPE_TYPE_MASK) return(nilCell);
6891 return(trueCell);
6892 }
6893
p_isQuote(CELL * params)6894 CELL * p_isQuote(CELL *params)
6895 { return(isType(params, CELL_QUOTE)); }
6896
p_isList(CELL * params)6897 CELL * p_isList(CELL * params)
6898 { return(isType(params, CELL_EXPRESSION)); }
6899
p_isLambda(CELL * params)6900 CELL * p_isLambda(CELL * params)
6901 { return(isType(params, CELL_LAMBDA)); }
6902
p_isMacro(CELL * params)6903 CELL * p_isMacro(CELL * params)
6904 {
6905 SYMBOL * sPtr;
6906
6907 if(params == nilCell)
6908 return(errorProc(ERR_MISSING_ARGUMENT));
6909 params = evaluateExpression(params);
6910 if(params->type == CELL_FEXPR) /* lambda-macro */
6911 return(trueCell);
6912 if(params->type == CELL_SYMBOL)
6913 {
6914 sPtr = (SYMBOL *)params->contents;
6915 if(sPtr->flags & SYMBOL_MACRO)
6916 return(trueCell);
6917 }
6918 return(nilCell);
6919 }
6920
p_isArray(CELL * params)6921 CELL * p_isArray(CELL * params)
6922 { return(isType(params, CELL_ARRAY)); }
6923
isType(CELL * params,int operand)6924 CELL * isType(CELL * params, int operand)
6925 {
6926 CELL * contextCell;
6927
6928 if(params == nilCell)
6929 return(errorProc(ERR_MISSING_ARGUMENT));
6930 params = evaluateExpression(params);
6931 if((UINT)operand == params->type) return(trueCell);
6932 switch(operand)
6933 {
6934 case CELL_PRIMITIVE:
6935 if(params->type == CELL_IMPORT_CDECL
6936 || params->type == CELL_IMPORT_FFI
6937 #if defined(WINDOWS) || defined(CYGWIN)
6938 || params->type == CELL_IMPORT_DLL
6939 #endif
6940 )
6941 return(trueCell);
6942 break;
6943 case CELL_EXPRESSION:
6944 if(isList(params->type)) return(trueCell);
6945 break;
6946 case CELL_SYMBOL:
6947 if(params->type == CELL_DYN_SYMBOL) /* check if already created */
6948 {
6949 contextCell = (CELL *)((SYMBOL *)params->aux)->contents;
6950 if(contextCell->type != CELL_CONTEXT)
6951 fatalError(ERR_CONTEXT_EXPECTED,
6952 stuffSymbol((SYMBOL*)params->aux), TRUE);
6953 if(lookupSymbol((char *)params->contents, (SYMBOL*)contextCell->contents))
6954 return(trueCell);
6955 }
6956
6957 break;
6958 default:
6959 break;
6960 }
6961
6962 return(nilCell);
6963 }
6964
6965
p_isLegal(CELL * params)6966 CELL * p_isLegal(CELL * params)
6967 {
6968 char * symStr;
6969
6970 getString(params, &symStr);
6971
6972 if(isLegalSymbol(symStr)) return(trueCell);
6973
6974 return(nilCell);
6975 }
6976
6977
isLegalSymbol(char * source)6978 int isLegalSymbol(char * source)
6979 {
6980 STREAM stream;
6981 char token[MAX_SYMBOL + 1];
6982 int tklen;
6983
6984 if(*source == (char)'"' || *source == (char)'{'
6985 || (unsigned char)*source <= (unsigned char)' ' || *source == (char)';' || *source == (char)'#')
6986 return(0);
6987
6988 makeStreamFromString(&stream, source);
6989
6990 return(getToken(&stream, token, &tklen) == TKN_SYMBOL && tklen == stream.size - 4 * MAX_STRING);
6991 }
6992
p_exit(CELL * params)6993 CELL * p_exit(CELL * params)
6994 {
6995 UINT result;
6996
6997 #ifndef EMSCRIPTEN
6998 if(daemonMode)
6999 {
7000 fclose(IOchannel);
7001 #ifndef WINDOWS
7002 IOchannel = NULL;
7003 #endif
7004 longjmp(errorJump, ERR_USER_RESET);
7005 }
7006 #else
7007 return(nilCell);
7008 #endif
7009
7010 if(params != nilCell) getInteger(params, &result);
7011 else result = 0;
7012
7013 #ifdef HAVE_FORK
7014 /* release spawn resources */
7015 purgeSpawnList(TRUE);
7016 #endif
7017
7018 exit(result);
7019 return(trueCell);
7020 }
7021
7022
7023 #ifdef EMSCRIPTEN
emscriptenReload(void)7024 void emscriptenReload(void)
7025 {
7026 char * cmd = "location.reload();";
7027 printf("# newLISP is reloading ...\n");
7028 evalStringJS(cmd, strlen(cmd));
7029 }
7030 #endif
7031
7032
p_reset(CELL * params)7033 CELL * p_reset(CELL * params)
7034 {
7035 int blockCountBefore = blockCount;
7036
7037 if(params != nilCell)
7038 {
7039 params = evaluateExpression(params);
7040 if(isNumber(params->type))
7041 {
7042 getIntegerExt(params, (UINT*)&MAX_CELL_COUNT, FALSE);
7043 if(MAX_CELL_COUNT < MAX_BLOCK) MAX_CELL_COUNT = MAX_BLOCK;
7044 return(stuffInteger(MAX_CELL_COUNT));
7045 }
7046 else if(isNil(params))
7047 {
7048 freeCellBlocks();
7049 return(stuffIntegerList(2, blockCountBefore, blockCount)); /* 10.3.3 */
7050 }
7051 #ifndef LIBRARY
7052 #ifndef WINDOWS
7053 else
7054 execv(MainArgs[0], MainArgs);
7055 #endif
7056 #endif
7057 #ifdef EMSCRIPTEN
7058 emscriptenReload();
7059 #endif
7060 }
7061 else
7062 #ifndef EMSCRIPTEN
7063 longjmp(errorJump, ERR_USER_RESET);
7064 #else
7065 return(nilCell);
7066 #endif
7067
7068 return(trueCell);
7069 }
7070
setEvent(CELL * params,SYMBOL ** eventSymPtr,char * sysSymName)7071 CELL * setEvent(CELL * params, SYMBOL * * eventSymPtr, char * sysSymName)
7072 {
7073 if(params != nilCell) getCreateSymbol(params, eventSymPtr, sysSymName);
7074 return(makeCell(CELL_SYMBOL, (UINT)*eventSymPtr));
7075 }
7076
p_errorEvent(CELL * params)7077 CELL * p_errorEvent(CELL * params)
7078 {
7079 return(setEvent(params, &errorEvent, "$error-event"));
7080 }
7081
p_promptEvent(CELL * params)7082 CELL * p_promptEvent(CELL * params)
7083 {
7084 return(setEvent(params, &promptEvent, "$prompt-event"));
7085 }
7086
p_commandEvent(CELL * params)7087 CELL * p_commandEvent(CELL * params)
7088 {
7089 return(setEvent(params, &commandEvent, "$command-event"));
7090 }
7091
p_transferEvent(CELL * params)7092 CELL * p_transferEvent(CELL * params)
7093 {
7094 return(setEvent(params, &transferEvent, "$transfer-event"));
7095 }
7096
p_readerEvent(CELL * params)7097 CELL * p_readerEvent(CELL * params)
7098 {
7099 return(setEvent(params, &readerEvent, "$reader-event"));
7100 }
7101
7102
7103 #ifndef WINDOWS
7104
p_timerEvent(CELL * params)7105 CELL * p_timerEvent(CELL * params)
7106 {
7107 double seconds;
7108 UINT timerOption = 0;
7109 struct itimerval timerVal;
7110 struct itimerval outVal;
7111 static double duration;
7112
7113 if(params != nilCell)
7114 {
7115 params = getCreateSymbol(params, &timerEvent, "$timer");
7116
7117 if(params != nilCell)
7118 {
7119 params = getFloat(params, &seconds);
7120 duration = seconds;
7121 if(params != nilCell)
7122 getInteger(params, &timerOption);
7123 memset(&timerVal, 0, sizeof(timerVal));
7124 timerVal.it_value.tv_sec = seconds;
7125 timerVal.it_value.tv_usec = (seconds - timerVal.it_value.tv_sec) * 1000000;
7126 if(setitimer((int)timerOption, &timerVal, &outVal) == -1)
7127 return(nilCell);
7128 return(stuffInteger(0));
7129 }
7130 else
7131 getitimer(timerOption, &outVal);
7132
7133 seconds = duration - (outVal.it_value.tv_sec + outVal.it_value.tv_usec / 1000000.0);
7134 return(stuffFloat(seconds));
7135 }
7136
7137 return(makeCell(CELL_SYMBOL, (UINT)timerEvent));
7138 }
7139 #endif
7140
7141 #ifndef EMSCRIPTEN
7142 #define IGNORE_S 0
7143 #define DEFAULT_S 1
7144 #define RESET_S 2
p_signal(CELL * params)7145 CELL * p_signal(CELL * params)
7146 {
7147 SYMBOL * signalEvent;
7148 UINT sig;
7149 char sigStr[12];
7150 char mode;
7151
7152 params = getInteger(params, &sig);
7153 if(sig > 32 || sig < 1) return(nilCell);
7154
7155 if(params->type == CELL_STRING)
7156 {
7157 mode = toupper(*(char *)params->contents);
7158 symHandler[sig - 1] = nilSymbol;
7159 if(mode == 'I') /* "ignore" */
7160 return(signal(sig, SIG_IGN) == SIG_ERR ? nilCell: trueCell);
7161 else if(mode == 'D') /* "default" */
7162 return(signal(sig, SIG_DFL) == SIG_ERR ? nilCell: trueCell);
7163 else if(mode == 'R') /* "reset" */
7164 return(signal(sig, signal_handler) == SIG_ERR ? nilCell: trueCell);
7165 }
7166 else if(params != nilCell)
7167 {
7168 snprintf(sigStr, 11, "$signal-%d", (int)sig);
7169 getCreateSymbol(params, &signalEvent, sigStr);
7170 symHandler[sig - 1] = signalEvent;
7171 if(signal(sig, signal_handler) == SIG_ERR) return(nilCell);
7172 }
7173
7174 return(makeCell(CELL_SYMBOL, (UINT)symHandler[sig - 1]));
7175 }
7176 #endif
7177
p_lastError(CELL * params)7178 CELL * p_lastError(CELL * params)
7179 {
7180 CELL * result;
7181 char * sPtr;
7182 UINT errNum = errorReg;
7183
7184 if(params != nilCell)
7185 getInteger(params, &errNum);
7186
7187 if(!errNum) return(nilCell);
7188
7189 result = makeCell(CELL_EXPRESSION, (UINT)stuffInteger(errNum));
7190 if(params != nilCell)
7191 sPtr = (errNum > MAX_ERROR_NUMBER) ? UNKNOWN_ERROR : errorMessage[errNum];
7192 else
7193 sPtr = errorStream.buffer;
7194
7195 ((CELL *)result->contents)->next = stuffString(sPtr);
7196
7197 return(result);
7198 }
7199
7200
p_dump(CELL * params)7201 CELL * p_dump(CELL * params)
7202 {
7203 CELL * blockPtr;
7204 CELL * cell;
7205 UINT count = 0;
7206 int i;
7207
7208 if(params != nilCell)
7209 {
7210 cell = evaluateExpression(params);
7211 return(stuffIntegerList
7212 (5, cell, cell->type, cell->next, cell->aux, cell->contents));
7213 }
7214
7215 blockPtr = cellMemory;
7216 while(blockPtr != NULL)
7217 {
7218 for(i = 0; i < MAX_BLOCK; i++)
7219 {
7220 if(*(UINT *)blockPtr != CELL_FREE)
7221 {
7222 varPrintf(OUT_DEVICE, "address=%lX type=%d contents=", blockPtr, blockPtr->type);
7223 printCell(blockPtr, TRUE, OUT_DEVICE);
7224 varPrintf(OUT_DEVICE, LINE_FEED);
7225 ++count;
7226 }
7227 ++blockPtr;
7228 }
7229 blockPtr = blockPtr->next;
7230 }
7231
7232 return(stuffInteger(count));
7233 }
7234
7235
p_mainArgs(CELL * params)7236 CELL * p_mainArgs(CELL * params)
7237 {
7238 CELL * cell;
7239 ssize_t idx;
7240
7241 cell = (CELL*)mainArgsSymbol->contents;
7242 if(params != nilCell && cell->type == CELL_EXPRESSION)
7243 {
7244 getInteger(params, (UINT *)&idx);
7245 cell = (CELL *)cell->contents;
7246 if(idx < 0) idx = convertNegativeOffset(idx, (CELL *)cell);
7247 while(idx--) cell = cell->next;
7248 }
7249
7250 return(copyCell(cell));
7251 }
7252
7253
p_context(CELL * params)7254 CELL * p_context(CELL * params)
7255 {
7256 CELL * cell;
7257 SYMBOL * sPtr;
7258 SYMBOL * cPtr;
7259 char * newSymStr;
7260
7261 if(params->type == CELL_NIL)
7262 return(copyCell((CELL *)currentContext->contents));
7263
7264 if((cPtr = getCreateContext(params, TRUE)) == NULL)
7265 return(errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, params));
7266
7267 if(params->next == nilCell)
7268 {
7269 currentContext = cPtr;
7270 return(copyCell( (CELL *)currentContext->contents));
7271 }
7272
7273 params = params->next;
7274 cell = evaluateExpression(params);
7275 if(cell->type == CELL_STRING)
7276 {
7277 if(cell->aux - 1 > MAX_SYMBOL)
7278 return(errorProcExt(ERR_STRING_TOO_LONG, cell));
7279 newSymStr = (char *)cell->contents;
7280 }
7281 else if(cell->type == CELL_SYMBOL)
7282 newSymStr = ((SYMBOL *)cell->contents)->name;
7283 else if(cell->type == CELL_DYN_SYMBOL)
7284 {
7285 sPtr = getDynamicSymbol(cell);
7286 newSymStr = sPtr->name;
7287 }
7288 else
7289 return(errorProcExt(ERR_ILLEGAL_TYPE, cell));
7290
7291
7292 if(params->next == nilCell)
7293 {
7294 pushResultFlag = FALSE;
7295 sPtr = lookupSymbol(newSymStr, cPtr);
7296 if(sPtr == NULL)
7297 return(nilCell);
7298 else
7299 return((CELL *)sPtr->contents);
7300 }
7301
7302
7303 sPtr = translateCreateSymbol(newSymStr, CELL_NIL, cPtr, TRUE);
7304
7305 return(setDefine(sPtr, params->next, SET_SET));
7306 }
7307
7308
getCreateContext(CELL * cell,int evaluate)7309 SYMBOL * getCreateContext(CELL * cell, int evaluate)
7310 {
7311 SYMBOL * contextSymbol;
7312
7313 if(evaluate)
7314 cell = evaluateExpression(cell);
7315 if(cell->type == CELL_SYMBOL || cell->type == CELL_CONTEXT)
7316 contextSymbol = (SYMBOL *)cell->contents;
7317 else
7318 return(NULL);
7319
7320
7321 if(symbolType(contextSymbol) != CELL_CONTEXT)
7322 {
7323 if(contextSymbol->context != mainContext)
7324 {
7325 contextSymbol= translateCreateSymbol(
7326 contextSymbol->name, CELL_CONTEXT, mainContext, 1);
7327 }
7328
7329 if(symbolType(contextSymbol) != CELL_CONTEXT)
7330 {
7331 if(isProtected(contextSymbol->flags))
7332 errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(contextSymbol));
7333
7334 deleteList((CELL *)contextSymbol->contents);
7335 makeContextFromSymbol(contextSymbol, NULL);
7336 }
7337 }
7338
7339 /* if this is a context var retrieve the real context symbol */
7340 return((SYMBOL *)((CELL *)contextSymbol->contents)->contents);
7341 }
7342
7343
p_default(CELL * params)7344 CELL * p_default(CELL * params)
7345 {
7346 SYMBOL * contextSymbol;
7347
7348 getContext(params, &contextSymbol);
7349
7350 symbolCheck = translateCreateSymbol(contextSymbol->name, CELL_NIL, contextSymbol, TRUE);
7351 pushResultFlag = FALSE;
7352 return((CELL *)symbolCheck->contents);
7353 }
7354
7355
7356 /* FOOP fuctions */
7357
7358 /* filled in colon, only used internally and by obj function */
7359 /* need stack for objSymbol.contents */
7360 /* what happens to stack when using catch/throw */
7361
p_colon(CELL * params)7362 CELL * p_colon(CELL * params)
7363 {
7364 SYMBOL * contextSymbol = NULL;
7365 SYMBOL * methodSymbol;
7366 SYMBOL * sPtr;
7367 CELL * proc;
7368 CELL * cell;
7369 CELL * obj;
7370 CELL * objSave;
7371 CELL * objCellSave;
7372 SYMBOL * objSymbolContextSave;
7373 int objSymbolFlagsSave;
7374
7375 if(params->type != CELL_SYMBOL)
7376 return(errorProcExt(ERR_SYMBOL_EXPECTED, params));
7377
7378 methodSymbol = (SYMBOL *)params->contents;
7379 params = getEvalDefault(params->next, &obj);
7380
7381 objSymbolFlagsSave = objSymbol.flags;
7382 objSymbolContextSave = objSymbol.context;
7383 if(symbolCheck)
7384 {
7385 objSymbol.flags = symbolCheck->flags;
7386 objSymbol.context = symbolCheck->context;
7387 }
7388
7389 objSave = (CELL *)objSymbol.contents;
7390 objCellSave = objCell;
7391 objCell = obj;
7392
7393 #ifdef FOOP_DEBUG
7394 printf("entering colon, saving in objSave:");
7395 printCell(objSave, TRUE, OUT_CONSOLE);
7396 puts("");
7397 #endif
7398
7399 cell = (CELL *)obj->contents;
7400 if(obj->type != CELL_EXPRESSION)
7401 return(errorProcExt(ERR_LIST_EXPECTED, obj));
7402
7403 if(cell->type == CELL_SYMBOL || cell->type == CELL_CONTEXT)
7404 contextSymbol = (SYMBOL *)cell->contents;
7405 if(contextSymbol == NULL || symbolType(contextSymbol) != CELL_CONTEXT)
7406 return(errorProcExt(ERR_CONTEXT_EXPECTED, cell));
7407
7408 sPtr = methodSymbol;
7409 if((methodSymbol = lookupSymbol(sPtr->name, contextSymbol)) == NULL)
7410 return(errorProcExt2(ERR_INVALID_FUNCTION, stuffSymbol(sPtr)));
7411
7412 cell = stuffSymbol(methodSymbol);
7413 proc = makeCell(CELL_EXPRESSION, (UINT)cell);
7414
7415 while(params != nilCell)
7416 {
7417 cell->next = copyCell(params);
7418 cell = cell->next;
7419 params = params->next;
7420 }
7421
7422 pushResult(proc);
7423
7424 #ifdef FOOP_DEBUG
7425 printf("colon calling %s in %s with objCell:", methodSymbol->name, contextSymbol->name);
7426 printCell(objCell, TRUE, OUT_CONSOLE);
7427 puts("");
7428 #endif
7429
7430 cell = copyCell(evaluateExpression(proc));
7431
7432 objSymbol.flags = objSymbolFlagsSave;
7433 objSymbol.context = objSymbolContextSave;
7434
7435 objSymbol.contents = (UINT)objSave;
7436 objCell = objCellSave;
7437
7438 #ifdef FOOP_DEBUG
7439 printf("leavin colon, objCell restored to:");
7440 printCell(obj, TRUE, OUT_CONSOLE);
7441 puts("");
7442 #endif
7443
7444
7445 return(cell);
7446 }
7447
p_self(CELL * params)7448 CELL * p_self(CELL * params)
7449 {
7450 CELL * result;
7451
7452 if(objSymbol.contents == (UINT)nilCell)
7453 return(nilCell);
7454
7455 if(params == nilCell)
7456 {
7457 symbolCheck = &objSymbol;
7458 pushResultFlag = FALSE;
7459 return((CELL *)objSymbol.contents);
7460 }
7461
7462 result = implicitIndexList((CELL*)objSymbol.contents, params);
7463
7464 symbolCheck = &objSymbol;
7465 pushResultFlag = FALSE;
7466
7467 return(result);
7468 }
7469
7470
p_systemSymbol(CELL * params)7471 CELL * p_systemSymbol(CELL * params)
7472 {
7473 UINT idx;
7474
7475 getInteger(params, &idx);
7476
7477 if(idx > 15) return(nilCell);
7478
7479 return(copyCell((CELL*)sysSymbol[idx]->contents));
7480 }
7481
7482
7483 /* end of file */
7484