?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Initial commit of newLISP.
[newlisp.git] / newlisp.c
blobc6d6443985c43212acd3ef062946537126c939dd
1 /* newlisp.c --- enrty point and main functions for newLISP
2
3 Copyright (C) 2008 Lutz Mueller
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program. If not, see <http://www.gnu.org/licenses/>.
17 */
18
19 #include "newlisp.h"
20 #include "pcre.h"
21 #include "protos.h"
22 #include "primes.h"
23
24 #ifdef WIN_32
25 #include <winsock2.h>
26 #endif
27
28 #ifdef READLINE
29 #include <readline/readline.h>
30 #include <readline/history.h>
31 #endif
32
33 #ifdef SUPPORT_UTF8
34 #include <wctype.h>
35 #endif
36
37 #ifdef IPV6
38 #define IPV 6
39 #else
40 #define IPV 4
41 #endif
42
43 #define freeMemory free
44
45 #ifdef WIN_32
46 #define INIT_FILE "init.lsp"
47 #define fprintf win32_fprintf
48 #define fgets win32_fgets
49 #define fclose win32_fclose
50 #else
51 #define INIT_FILE "/usr/share/newlisp/init.lsp"
52 #endif
53
54 #ifdef LIBRARY
55 extern STREAM libStrStream;
56 #endif
57
58 #ifdef LINUX
59 int opsys = 1;
60 char ostype[]="Linux";
61 #endif
62
63 #ifdef _BSD
64 int opsys = 2;
65 char ostype[]="BSD";
66 #endif
67
68 #ifdef MAC_OSX
69 int opsys = 3;
70 char ostype[]="OSX";
71 #endif
72
73 #ifdef SOLARIS
74 #ifdef TRU64
75 int opsys = 9;
76 char ostype[]="Tru64Unix";
77 #else
78 int opsys = 4;
79 char ostype[]="Solaris";
80 #endif
81 #endif
82
83 #ifdef WIN_32
84 int opsys = 6;
85 char ostype[]="Win32";
86 #endif
87
88 #ifdef OS2
89 int opsys = 7;
90 char ostype[]="OS/2";
91 #endif
92
93 int version = 9303;
94
95 char copyright[]=
96 "\nnewLISP v.9.3.3 Copyright (c) 2008 Lutz Mueller. All rights reserved.\n\n%s\n\n";
97
98 #ifndef NEWLISP64
99 #ifdef SUPPORT_UTF8
100 char banner[]=
101 "newLISP v.9.3.3 on %s IPv%d UTF-8%s\n\n";
102 #else
103 char banner[]=
104 "newLISP v.9.3.3 on %s IPv%d%s\n\n";
105 #endif
106 #else
107 #ifdef SUPPORT_UTF8
108 char banner[]=
109 "newLISP v.9.3.3 64-bit on %s IPv%d UTF-8%s\n\n";
110 #else
111 char banner[]=
112 "newLISP v.9.3.3 64-bit on %s IPv%d%s\n\n";
113 #endif
114 #endif
115
116 char banner2[]=
117 ", execute 'newlisp -h' for more info.";
118
119 char linkOffset[] = "@@@@@@@@";
120
121 void printHelpText(void);
122
123 /* --------------------- globals -------------------------------------- */
124
125 /* interactive command line */
126
127 int commandLineFlag = TRUE;
128 int isTTY = FALSE;
129 int demonMode = 0;
130
131 int noPromptMode = 0;
132 int forcePromptMode = 0;
133 int httpMode = 0;
134
135 FILE * IOchannel;
136 int IOport = 0;
137 char * IOdomain = NULL;
138 int logTraffic = 0;
139 #define LOG_LESS 1
140 #define LOG_MORE 2
141
142 /* initialization */
143 int MAX_CPU_STACK = 0x800;
144 int MAX_ENV_STACK;
145 int MAX_RESULT_STACK;
146 #ifndef NEWLISP64
147 long MAX_CELL_COUNT = 0x10000000;
148 #else
149 long MAX_CELL_COUNT = 0x800000000000000LL;
150 #endif
151
152 CELL * firstFreeCell = NULL;
153
154 CELL * nilCell;
155 CELL * trueCell;
156 CELL * lastCellCopied;
157 SYMBOL * nilSymbol;
158 SYMBOL * trueSymbol;
159 SYMBOL * starSymbol;
160 SYMBOL * plusSymbol;
161 SYMBOL * questionSymbol;
162 SYMBOL * atSymbol;
163 SYMBOL * currentFunc;
164 SYMBOL * argsSymbol;
165 SYMBOL * mainArgsSymbol;
166 SYMBOL * dolistIdxSymbol;
167
168 SYMBOL * sysSymbol[MAX_REGEX_EXP];
169
170 SYMBOL * errorEvent;
171 SYMBOL * currentContext = NULL;
172 SYMBOL * mainContext = NULL;
173 SYMBOL * demonRequest;
174 SYMBOL * timerEvent;
175
176 SYMBOL * symHandler[32];
177 int currentSignal = 0;
178
179 jmp_buf errorJump;
180
181 char lc_decimal_point;
182
183 /* error and exception handling */
184
185 #define EXCEPTION_THROW -1
186 int errorReg = 0;
187 CELL * throwResult;
188 int errnoSave;
189
190 /* buffer for read-line */
191 STREAM readLineStream;
192
193 /* compiler */
194
195 size_t cellCount = 0;
196 size_t symbolCount = 0;
197
198 int parStackCounter = 0;
199
200 /* expression evaluation */
201
202 static CELL * (*evalFunc)(CELL *) = NULL;
203 UINT * envStack = NULL;
204 UINT * resultStack = NULL;
205 UINT * lambdaStack = NULL;
206 int envStackIdx, resultStackIdx, lambdaStackIdx;
207 int evalSilent = 0;
208
209 extern PRIMITIVE primitive[];
210
211 int traceFlag = 0;
212 int evalCatchFlag = 0;
213 int recursionCount = 0;
214 int symbolProtectionLevel = 0;
215
216 int prettyPrintPars = 0;
217 int prettyPrintCurrent = 0;
218 int prettyPrintFlags = 0;
219 int prettyPrintLength = 0;
220 char * prettyPrintTab = " ";
221 #define MAX_PRETTY_PRINT_LENGTH 80
222 UINT prettyPrintMaxLength = MAX_PRETTY_PRINT_LENGTH;
223 int stringOutputRaw = TRUE;
224
225 #define pushLambda(A) (*(lambdaStack + lambdaStackIdx++) = (UINT)(A))
226 #define popLambda() ((CELL *)*(lambdaStack + --lambdaStackIdx))
227
228 int pushResultFlag = TRUE;
229
230 char startupDir[PATH_MAX]; /* start up directory, if defined via -w */
231 char logFile[PATH_MAX]; /* logFile, is define with -l, -L */
232
233 /* ============================== MAIN ================================ */
234
235 /*
236 void setupSignalHandler(int sig, void (* handler)(int))
237 {
238 static struct sigaction sig_act;
239 sig_act.sa_handler = handler;
240 sigemptyset(&sig_act.sa_mask);
241 sig_act.sa_flags = SA_RESTART | SA_NOCLDSTOP;
242 if(sigaction(sig, &sig_act, 0) != 0)
243 printf("Error setting signal:%d handler\n", sig);
244 }
245 */
246
247 void setupSignalHandler(int sig, void (* handler)(int))
248 {
249 if(signal(sig, handler) == SIG_ERR)
250 printf("Error setting signal:%d handler\n", sig);
251 }
252
253 #ifdef SOLARIS
254 void sigpipe_handler(int sig)
255 {
256 setupSignalHandler(SIGPIPE, sigpipe_handler);
257 }
258
259 void sigchld_handler(int sig)
260 {
261 waitpid(-1, (int *)0, WNOHANG);
262 }
263
264 void ctrlC_handler(int sig)
265 {
266 char chr;
267
268 setupSignalHandler(SIGINT, ctrlC_handler);
269
270 if(commandLineFlag != TRUE) return;
271
272 traceFlag |= TRACE_SIGINT;
273
274 printErrorMessage(ERR_SIGINT, NULL, 0);
275 printf("(c)ontinue, e(x)it, (r)eset:");
276 fflush(NULL);
277 chr = getchar();
278 if(chr == 'x') exit(1);
279 if(chr == 'c') traceFlag &= ~TRACE_SIGINT;
280 }
281
282
283 void sigalrm_handler(int sig)
284 {
285 setupSignalHandler(sig, sigalrm_handler);
286 /* check if not sitting idle */
287 if(recursionCount)
288 traceFlag |= TRACE_TIMER;
289 else /* if idle */
290 executeSymbol(timerEvent, NULL);
291 }
292
293 #endif /* solaris */
294
295
296 void setupAllSignals(void)
297 {
298 #ifdef SOLARIS
299 setupSignalHandler(SIGINT,ctrlC_handler);
300 #else
301 setupSignalHandler(SIGINT, signal_handler);
302 #endif
303
304 #ifndef WIN_32
305
306 #ifdef SOLARIS
307 setupSignalHandler(SIGALRM, sigalrm_handler);
308 setupSignalHandler(SIGVTALRM, sigalrm_handler);
309 setupSignalHandler(SIGPROF, sigalrm_handler);
310 setupSignalHandler(SIGPIPE, sigpipe_handler);
311 setupSignalHandler(SIGCHLD, sigchld_handler);
312 #else
313 setupSignalHandler(SIGALRM, signal_handler);
314 setupSignalHandler(SIGVTALRM, signal_handler);
315 setupSignalHandler(SIGPROF, signal_handler);
316 setupSignalHandler(SIGPIPE, signal_handler);
317 setupSignalHandler(SIGCHLD, signal_handler);
318 #endif
319
320 #endif
321 }
322
323 void signal_handler(int sig)
324 {
325 #ifndef WIN_32
326 char chr;
327 #endif
328
329 if(sig > 32 || sig < 1) return;
330
331 #ifdef SOLARIS
332 switch(sig)
333 {
334 case SIGALRM:
335 case SIGVTALRM:
336 case SIGPROF:
337 setupSignalHandler(sig, sigalrm_handler);
338 break;
339 case SIGPIPE:
340 setupSignalHandler(SIGPIPE, sigpipe_handler);
341 break;
342 case SIGCHLD:
343 setupSignalHandler(SIGCHLD, sigchld_handler);
344 break;
345 }
346 #else
347 setupSignalHandler(sig, signal_handler);
348 #endif
349
350 if(symHandler[sig - 1] != nilSymbol)
351 {
352 if(recursionCount)
353 {
354 currentSignal = sig;
355 traceFlag |= TRACE_SIGNAL;
356 return;
357 }
358 else
359 {
360 executeSymbol(symHandler[sig-1], stuffInteger(sig));
361 return;
362 }
363 }
364
365 switch(sig)
366 {
367 case SIGINT:
368 if(commandLineFlag != TRUE) return;
369
370 printErrorMessage(ERR_SIGINT, NULL, 0);
371
372 #ifdef WIN_32
373 traceFlag |= TRACE_SIGINT;
374 #else
375 printf("\n(c)ontinue, (d)ebug, e(x)it, (r)eset:");
376 fflush(NULL);
377 chr = getchar();
378 if(chr == 'x') exit(1);
379 if(chr == 'd')
380 {
381 traceFlag &= ~TRACE_SIGINT;
382 openTrace();
383 }
384 if(chr == 'r') traceFlag |= TRACE_SIGINT;
385 break;
386 case SIGPIPE:
387 break;
388 case SIGALRM:
389 case SIGVTALRM:
390 case SIGPROF:
391 /* check if not sitting idle */
392 if(recursionCount)
393 traceFlag |= TRACE_TIMER;
394 else /* if idle */
395 executeSymbol(timerEvent, NULL);
396 break;
397 case SIGCHLD:
398 waitpid(-1, (int *)0, WNOHANG);
399 #endif
400 break;
401 default:
402 return;
403 }
404 }
405
406
407 void loadStartup(char * name)
408 {
409 #ifdef WIN_32
410 #ifndef LIBRARY
411 char * ptr;
412 char EXEName[MAX_LINE];
413 char initFile[MAX_LINE];
414
415 GetModuleFileName(NULL, EXEName, MAX_LINE);
416 name = EXEName;
417 #endif
418 #endif
419
420 if(strncmp(linkOffset, "@@@@", 4) == 0)
421 {
422 #ifdef WIN_32
423 #ifndef LIBRARY
424 ptr = name + strlen(name) - 1;
425 while(ptr != name)
426 {
427 if(*ptr == '/' || *ptr == '\\') break;
428 ptr--;
429 }
430 *ptr = 0;
431 strncpy(initFile, name, MAX_LINE - 9);
432 strcat(initFile, "/");
433 strcat(initFile, INIT_FILE);
434 loadFile(initFile, 0, 0, mainContext);
435 #else
436 loadFile(INIT_FILE, 0, 0, mainContext);
437 #endif
438 #else
439 loadFile(INIT_FILE, 0, 0, mainContext);
440 #endif
441 }
442 else /* load encrypted part at offset */
443 loadFile(name, *(UINT*)linkOffset, 1, mainContext);
444 }
445
446
447 #ifdef _BSD
448 struct lconv *localeconv(void);
449 char *setlocale(int, const char *);
450 #endif
451
452 void initLocale(void)
453 {
454 struct lconv * lc;
455 char * locale;
456
457 #ifndef SUPPORT_UTF8
458 locale = setlocale(LC_ALL, "C");
459 #else
460 locale = setlocale(LC_ALL, "");
461 #endif
462
463 if (locale != NULL)
464 stringOutputRaw = (strcmp(locale, "C") == 0);
465
466 lc = localeconv();
467 lc_decimal_point = *lc->decimal_point;
468 }
469
470 /* set NEWLISPDIR only if not set already */
471 void initNewlispDir(void)
472 {
473 #ifdef WIN_32
474 char * varValue;
475 char * newlispDir;
476
477 if(getenv("NEWLISPDIR") == NULL)
478 {
479 newlispDir = alloca(MAX_PATH);
480 varValue = getenv("PROGRAMFILES");
481 if(varValue != NULL)
482 {
483 strncpy(newlispDir, varValue, MAX_PATH);
484 strncat(newlispDir, "/newlisp", 8);
485 setenv("NEWLISPDIR", newlispDir, TRUE);
486 }
487 else setenv("NEWLISPDIR", "newlisp", TRUE);
488 }
489 #else
490 if(getenv("NEWLISPDIR") == NULL)
491 setenv("NEWLISPDIR", "/usr/share/newlisp", TRUE);
492 #endif
493 }
494
495 #ifndef LIBRARY
496 char * getArg(char * * arg, int argc, int * index)
497 {
498 if(strlen(arg[*index]) > 2)
499 return(arg[*index] + 2);
500
501 if(*index >= (argc - 1))
502 {
503 printf("missing parameter for %s\n", arg[*index]);
504 exit(-1);
505 }
506
507 *index = *index + 1;
508
509 return(arg[*index]);
510 }
511
512 #ifndef WIN_32
513 char ** MainArgs;
514 #endif
515
516 CELL * getMainArgs(char * mainArgs[])
517 {
518 CELL * argList;
519 #ifndef LIBRARY
520 CELL * lastEntry;
521 int idx = 0;
522 #endif
523
524 #ifndef WIN_32
525 MainArgs = mainArgs;
526 #endif
527
528 argList = getCell(CELL_EXPRESSION);
529
530 #ifndef LIBRARY
531 lastEntry = NULL;
532 while(mainArgs[idx] != NULL)
533 {
534 if(lastEntry == NULL)
535 {
536 lastEntry = stuffString(mainArgs[idx]);
537 argList->contents = (UINT)lastEntry;
538 }
539 else
540 {
541 lastEntry->next = stuffString(mainArgs[idx]);
542 lastEntry = lastEntry->next;
543 }
544 idx++;
545 }
546 #endif
547
548 return(argList);
549 }
550
551
552 int main(int argc, char * argv[])
553 {
554 char command[MAX_LINE];
555 STREAM cmdStream;
556 int idx;
557 #ifdef READLINE
558 char * cmd;
559 #endif
560
561 #ifdef WIN_32
562 WSADATA WSAData;
563 WSAStartup(MAKEWORD(1,1), &WSAData);
564 #endif
565
566 #ifdef SUPPORT_UTF8
567 opsys += 128;
568 #endif
569
570 memset(&cmdStream, 0, sizeof(STREAM));
571
572 initLocale();
573 initNewlispDir();
574 IOchannel = stdin;
575
576 initialize();
577 initStacks();
578
579 mainArgsSymbol->contents = (UINT)getMainArgs(argv);
580
581 if((errorReg = setjmp(errorJump)) != 0)
582 {
583 if(errorReg && (errorEvent != nilSymbol) && !isNil((CELL*)errorEvent->contents))
584 executeSymbol(errorEvent, NULL);
585 else exit(-1);
586 goto AFTER_ERROR_ENTRY;
587 }
588
589 setupAllSignals();
590
591 loadStartup(argv[0]);
592 errno = 0;
593
594 realpath(".", startupDir);
595
596 for(idx = 1; idx < argc; idx++)
597 {
598 #ifndef NOCMD
599 if(strncmp(argv[idx], "-c", 2) == 0)
600 noPromptMode = TRUE;
601
602 if(strncmp(argv[idx], "-C", 2) == 0)
603 forcePromptMode = TRUE;
604
605 if(strncmp(argv[idx], "-http", 5) == 0)
606 {
607 noPromptMode = TRUE;
608 httpMode = TRUE;
609 }
610
611 if(strncmp(argv[idx], "-s", 2) == 0)
612 {
613 MAX_CPU_STACK = atoi(getArg(argv, argc, &idx));
614
615 if(MAX_CPU_STACK < 1024) MAX_CPU_STACK = 1024;
616 initStacks();
617 continue;
618 }
619
620 if(strncmp(argv[idx], "-p", 2) == 0 || strncmp(argv[idx], "-d", 2) == 0 )
621 {
622 if(strncmp(argv[idx], "-d", 2) == 0)
623 demonMode = TRUE;
624
625 IOdomain = getArg(argv, argc, &idx);
626 IOport = atoi(IOdomain);
627
628 setupServer(0);
629 continue;
630 }
631
632 if(strncmp(argv[idx], "-e", 2) == 0)
633 {
634 executeCommandLine(getArg(argv, argc, &idx), OUT_CONSOLE, &cmdStream);
635 exit(0);
636 }
637
638 if(strncmp(argv[idx], "-l", 2) == 0 || strncmp(argv[idx], "-L", 2) == 0)
639 {
640 logTraffic = (strncmp(argv[idx], "-L", 2) == 0) ? LOG_MORE : LOG_LESS;
641 realpath(getArg(argv, argc, &idx), logFile);
642 continue;
643 }
644
645 if(strncmp(argv[idx], "-m", 2) == 0)
646 {
647 #ifndef NEWLISP64
648 MAX_CELL_COUNT = abs(0x0010000 * atoi(getArg(argv, argc, &idx)));
649 #else
650 MAX_CELL_COUNT = abs(0x0008000 * atoi(getArg(argv, argc, &idx)));
651 #endif
652 continue;
653 }
654
655 if(strncmp(argv[idx], "-w", 2) == 0)
656 {
657 realpath(getArg(argv, argc, &idx), startupDir);
658 chdir(startupDir);
659 continue;
660 }
661
662 if(strcmp(argv[idx], "-h") == 0)
663 {
664 printHelpText();
665 exit(0);
666 }
667 #endif
668
669 loadFile(argv[idx], 0, 0, mainContext);
670 }
671
672 AFTER_ERROR_ENTRY:
673
674 if(isatty(fileno(IOchannel)))
675 {
676 isTTY = TRUE;
677 if(!noPromptMode)
678 varPrintf(OUT_CONSOLE, banner, ostype, IPV, banner2);
679 }
680 else
681 {
682 #ifdef WIN_32
683 /* its a faked FILE struct, see win32_fdopen() in nl-sock.c */
684 if(!isSocketStream(IOchannel))
685 #endif
686 setbuf(IOchannel,0);
687 if(forcePromptMode)
688 varPrintf(OUT_CONSOLE, banner, ostype, IPV, banner2);
689 }
690
691
692 errorReg = setjmp(errorJump);
693
694 setupAllSignals();
695 reset();
696 initStacks();
697
698 if(errorReg && !isNil((CELL*)errorEvent->contents) )
699 executeSymbol(errorEvent, NULL);
700
701 while(TRUE)
702 {
703 if(commandLineFlag == TRUE)
704 {
705 #ifdef READLINE
706 if(isTTY)
707 {
708 errnoSave = errno;
709 if((cmd = readline(prompt())) == NULL) exit(0);
710 errno = errnoSave; /* reset errno, set by readline() */
711 if(strlen(cmd) > 0) add_history(cmd);
712 executeCommandLine(cmd, OUT_CONSOLE, &cmdStream);
713 free(cmd);
714 continue;
715 }
716
717 if(IOchannel != stdin || forcePromptMode)
718 varPrintf(OUT_CONSOLE, prompt());
719 #endif
720 #ifndef READLINE
721 if(isTTY || IOchannel != stdin || forcePromptMode)
722 varPrintf(OUT_CONSOLE, prompt());
723 #endif
724 if(IOchannel == NULL || fgets(command, MAX_LINE - 1, IOchannel) == NULL)
725 {
726 if(!demonMode) exit(1);
727 if(IOchannel != NULL) fclose(IOchannel);
728 setupServer(1);
729 continue;
730 }
731
732 executeCommandLine(command, OUT_CONSOLE, &cmdStream);
733 }
734 }
735
736 #ifndef WIN_32
737 return 0;
738 #endif
739 }
740 #endif
741
742
743 void printHelpText(void)
744 {
745 varPrintf(OUT_CONSOLE, copyright,
746 "usage: newlisp [file | url ...] [options ...] [file | url ...]\n\noptions:\n");
747 varPrintf(OUT_CONSOLE, "%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%s\n\n",
748 " -h this help",
749 " -s <stacksize>",
750 " -m <max-mem-megabyte>",
751 " -l log connections only",
752 " -L log all",
753 " -p <port-number>",
754 " -d <port-number>",
755 " -e <quoted lisp expression>",
756 " -c no prompts, HTTP",
757 " -C force prompts",
758 " -http HTTP only",
759 " -w <working-directory>",
760 "more information at http://newlisp.org");
761 }
762
763
764 void setupServer(int reconnect)
765 {
766 if((IOchannel = serverFD(IOport, IOdomain, reconnect)) == NULL)
767 {
768 printf("newLISP server setup on %s failed.\n", IOdomain);
769 exit(1);
770 }
771
772 #ifdef WIN_32
773 if(!isSocketStream(IOchannel))
774 #endif
775 setbuf(IOchannel,0);
776
777 if(!reconnect && !noPromptMode)
778 varPrintf(OUT_CONSOLE, banner, ostype, IPV, ".");
779 }
780
781
782 char * prompt(void)
783 {
784 char * context;
785 static char string[32];
786
787 if(evalSilent || noPromptMode)
788 {
789 evalSilent = 0;
790 return("");
791 }
792
793 if(currentContext != mainContext)
794 context = currentContext->name;
795 else context = "";
796
797 if(traceFlag & TRACE_SIGINT)
798 {
799 traceFlag &= ~TRACE_SIGINT;
800 longjmp(errorJump, errorReg);
801 }
802
803 if(traceFlag)
804 snprintf(string, 31, "%s %d> ", context, recursionCount);
805 else
806 snprintf(string, 31, "%s> ", context);
807
808 return(string);
809 }
810
811
812 void reset()
813 {
814 recoverEnvironment(0);
815
816 collectGarbage();
817
818 if(printDevice) close((int)printDevice);
819 printDevice = recursionCount = resultStackIdx = envStackIdx = lambdaStackIdx = 0;
820 symbolProtectionLevel = traceFlag = prettyPrintFlags = 0;
821 evalFunc = NULL;
822 pushResultFlag = commandLineFlag = TRUE;
823 currentContext = mainContext;
824 }
825
826
827 void recoverEnvironment(int index)
828 {
829 SYMBOL * symbol;
830 CELL * cell;
831
832 while(envStackIdx > index)
833 {
834 symbol = (SYMBOL *)popEnvironment();
835 cell = (CELL*)popEnvironment();
836 if(cell != (CELL*)symbol->contents)
837 {
838 deleteList((CELL*)symbol->contents);
839 symbol->contents = (UINT)cell;
840 if(isProtected(symbol->flags))
841 symbol->flags &= ~SYMBOL_PROTECTED;
842 }
843 }
844 }
845
846
847 void executeCommandLine(char * command, int outDevice, STREAM * cmdStream)
848 {
849 STREAM stream;
850 char buff[MAX_LINE];
851
852 if(strlen(command) == 0 || *command == '\n') return;
853
854 if(noPromptMode)
855 {
856 if(logTraffic == LOG_MORE)
857 writeLog(command, 0);
858 if(strncmp(command, "GET /", 5) == 0)
859 {
860 executeHTTPrequest(command + 5, HTTP_GET_URL);
861 return;
862 }
863 else if(strncmp(command, "HEAD /", 6) == 0)
864 {
865 executeHTTPrequest(command + 5, HTTP_GET_HEAD);
866 return;
867 }
868 else if(strncmp(command, "PUT /", 5) == 0)
869 {
870 executeHTTPrequest(command + 5, HTTP_PUT_URL);
871 return;
872 }
873 else if(strncmp(command, "POST /", 6) == 0)
874 {
875 executeHTTPrequest(command + 6, HTTP_POST_URL);
876 return;
877 }
878 else if(strncmp(command, "DELETE /", 8) == 0)
879 {
880 executeHTTPrequest(command + 8, HTTP_DELETE_URL);
881 return;
882 }
883
884 if(httpMode) return;
885 }
886
887 if(*command == '!' && *(command + 1) != ' ' && strlen(command) > 2)
888 {
889 system((command + 1));
890 return;
891 }
892
893 if(cmdStream != NULL && strncmp(command, "[cmd]", 5) == 0)
894 {
895 openStrStream(cmdStream, 1024, TRUE);
896 while(fgets(buff, MAX_LINE - 1, IOchannel) != NULL)
897 {
898 if(strncmp(buff, "[/cmd]", 6) == 0)
899 {
900 if(logTraffic)
901 {
902 writeLog(cmdStream->buffer, 0);
903 writeLog(buff, 0);
904 }
905 /* make stream for evaluation */
906 makeStreamFromString(&stream, cmdStream->buffer);
907 evaluateStream(&stream, OUT_CONSOLE, 0);
908 closeStrStream(cmdStream);
909 return;
910 }
911 writeStreamStr(cmdStream, buff, 0);
912 }
913 closeStrStream(cmdStream);
914 if(!demonMode) exit(1);
915 if(IOchannel != NULL) fclose(IOchannel);
916 setupServer(1);
917 return;
918 }
919
920 if(logTraffic) writeLog(command, TRUE);
921 prettyPrintLength = 0;
922
923 makeStreamFromString(&stream, command);
924 evaluateStream(&stream, outDevice, 0);
925
926 return;
927 }
928
929
930 CELL * evaluateStream(STREAM * stream, UINT outDevice, int flag)
931 {
932 CELL * program;
933 CELL * eval = nilCell;
934 int resultIdxSave;
935 int result;
936
937 result = TRUE;
938 resultIdxSave = resultStackIdx;
939 while(result)
940 {
941 pushResult(program = getCell(CELL_QUOTE));
942 result = compileExpression(stream, program);
943 if(result)
944 {
945 if(flag && eval != nilCell) deleteList(eval);
946 eval = evaluateExpression((CELL *)program->contents);
947 if(outDevice != 0 && !evalSilent)
948 {
949 printCell(eval, TRUE, outDevice);
950 varPrintf(outDevice, "\n");
951 if(logTraffic == LOG_MORE)
952 {
953 printCell(eval, TRUE, OUT_LOG);
954 writeLog("", TRUE);
955 }
956 }
957 if(flag) eval = copyCell(eval);
958 }
959 cleanupResults(resultIdxSave);
960 }
961
962 if(flag) return(eval);
963 return(NULL);
964 }
965
966
967 long executeSymbol(SYMBOL * symbol, CELL * params)
968 {
969 CELL * program;
970 CELL * cell;
971 int resultIdxSave;
972
973 if(symbol == nilSymbol || symbol == NULL) return(0);
974 resultIdxSave = resultStackIdx;
975 pushResult(program = getCell(CELL_EXPRESSION));
976 cell = getCell(CELL_SYMBOL);
977 program->contents = (UINT)cell;
978 cell->contents = (UINT)symbol;
979 if(params != NULL) cell->next = params;
980 cell = evaluateExpression(program);
981 cleanupResults(resultIdxSave);
982
983 return(cell->contents);
984 }
985
986
987 void initialize()
988 {
989 int i;
990 SYMBOL * symbol;
991 CELL * pCell;
992 char symName[8];
993
994 /* build true and false cells */
995
996 nilCell = getCell(CELL_NIL);
997 trueCell = getCell(CELL_TRUE);
998 nilCell->contents = (UINT)nilCell;
999 trueCell->contents = (UINT)trueCell;
1000 nilCell->next = trueCell->next = nilCell;
1001
1002 /* build first symbol and context MAIN */
1003 mainContext = currentContext = translateCreateSymbol("MAIN", CELL_CONTEXT, NULL, TRUE);
1004 makeContextFromSymbol(mainContext, mainContext);
1005
1006 /* build symbols for primitives */
1007
1008 for(i = 0; primitive[i].name != NULL; i++)
1009 {
1010 pCell = getCell(CELL_PRIMITIVE);
1011 symbol = translateCreateSymbol(
1012 primitive[i].name, CELL_PRIMITIVE, mainContext, TRUE);
1013 symbol->contents = (UINT)pCell;
1014 symbol->flags = primitive[i].prettyPrint | SYMBOL_PROTECTED | SYMBOL_GLOBAL | SYMBOL_BUILTIN;
1015 pCell->contents = (UINT)primitive[i].function;
1016 pCell->aux = (UINT)symbol->name;
1017 }
1018
1019 /* build true, nil, * and ? symbols */
1020
1021 trueSymbol = translateCreateSymbol("true", CELL_TRUE, mainContext, TRUE);
1022 trueSymbol->contents = (UINT)trueCell;
1023 nilSymbol = translateCreateSymbol("nil", CELL_NIL, mainContext, TRUE);
1024 nilSymbol->contents = (UINT)nilCell;
1025 starSymbol = translateCreateSymbol("*", CELL_PRIMITIVE, mainContext, TRUE);
1026 plusSymbol = translateCreateSymbol("+", CELL_PRIMITIVE, mainContext, TRUE);
1027 questionSymbol = translateCreateSymbol("?", CELL_NIL, mainContext, TRUE);
1028 atSymbol = translateCreateSymbol("@", CELL_NIL, mainContext, TRUE);
1029 argsSymbol = translateCreateSymbol("$args", CELL_NIL, mainContext, TRUE);
1030 mainArgsSymbol = translateCreateSymbol("$main-args", CELL_NIL, mainContext, TRUE);
1031 dolistIdxSymbol = translateCreateSymbol("$idx", CELL_NIL, mainContext, TRUE);
1032
1033 for(i = 0; i < MAX_REGEX_EXP; i++)
1034 {
1035 snprintf(symName, 8, "$%d", i);
1036 sysSymbol[i] = translateCreateSymbol(symName, CELL_NIL, mainContext, TRUE);
1037 sysSymbol[i]->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN;
1038 }
1039
1040 currentFunc = errorEvent = timerEvent = nilSymbol;
1041
1042 trueSymbol->flags |= SYMBOL_PROTECTED | SYMBOL_GLOBAL;
1043 nilSymbol->flags |= SYMBOL_PROTECTED | SYMBOL_GLOBAL;
1044 questionSymbol->flags |= SYMBOL_PROTECTED | SYMBOL_GLOBAL;
1045 atSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN;
1046 argsSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1047 mainArgsSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1048 dolistIdxSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1049 argsSymbol->contents = (UINT)getCell(CELL_EXPRESSION);
1050
1051 symbol = translateCreateSymbol("ostype", CELL_STRING, mainContext, TRUE);
1052 symbol->contents = (UINT)stuffString(ostype);
1053 symbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
1054
1055 /* init signal handlers */
1056 for(i = 0; i < 32; i++)
1057 symHandler[i] = nilSymbol;
1058
1059 /* init readLineStream */
1060 openStrStream(&readLineStream, 16, 0);
1061 }
1062
1063
1064 void initStacks()
1065 {
1066 MAX_ENV_STACK = (MAX_CPU_STACK * 8 * 2);
1067 MAX_RESULT_STACK = (MAX_CPU_STACK * 2);
1068 if(envStack != NULL) freeMemory(envStack);
1069 if(resultStack != NULL) freeMemory(resultStack);
1070 if(lambdaStack != NULL) freeMemory(lambdaStack);
1071 envStack = (UINT *)allocMemory((MAX_ENV_STACK + 16) * sizeof(UINT));
1072 resultStack = (UINT *)allocMemory((MAX_RESULT_STACK + 16) * sizeof(UINT));
1073 lambdaStack = (UINT *)allocMemory((MAX_RESULT_STACK + 16) * sizeof(UINT));
1074 envStackIdx = resultStackIdx = lambdaStackIdx = 0;
1075 }
1076
1077
1078 /* ------------------------- evaluate s-expression --------------------- */
1079
1080
1081 CELL * evaluateExpression(CELL * cell)
1082 {
1083 CELL * result;
1084 CELL * args = NULL;
1085 CELL * pCell = NULL;
1086 SYMBOL * newContext = NULL;
1087 SYMBOL * sPtr;
1088 int resultIdxSave = 0;
1089
1090 if(cell->type & EVAL_SELF_TYPE_MASK) return cell;
1091 switch(cell->type)
1092 {
1093 case CELL_SYMBOL:
1094 case CELL_CONTEXT:
1095 return((CELL*)((SYMBOL *)cell->contents)->contents);
1096
1097 case CELL_QUOTE:
1098 return((CELL *)cell->contents);
1099
1100 case CELL_EXPRESSION:
1101 args = (CELL *)cell->contents;
1102 resultIdxSave = resultStackIdx;
1103
1104 if(++recursionCount > (int)MAX_CPU_STACK)
1105 fatalError(ERR_OUT_OF_CALL_STACK, args, 0);
1106
1107 if(args->type == CELL_SYMBOL) /* precheck for speedup */
1108 {
1109 newContext = ((SYMBOL *)args->contents)->context;
1110 pCell = (CELL*)((SYMBOL *)args->contents)->contents;
1111 }
1112 else if(args->type == CELL_DYN_SYMBOL)
1113 {
1114 sPtr = getDynamicSymbol(args);
1115 newContext = sPtr->context;
1116 pCell = (CELL *)sPtr->contents;
1117 }
1118 else
1119 {
1120 pCell = evaluateExpression(args);
1121 newContext = currentContext;
1122 }
1123
1124 if(traceFlag) traceEntry(cell, pCell, args);
1125
1126 if(pCell->type == CELL_PRIMITIVE)
1127 {
1128 evalFunc = (CELL *(*)(CELL*))pCell->contents;
1129 result = (*evalFunc)(args->next);
1130 evalFunc = NULL;
1131 break;
1132 }
1133
1134 if(pCell->type == CELL_LAMBDA)
1135 {
1136 pushLambda(args);
1137 result = evaluateLambda((CELL *)pCell->contents, args->next, newContext);
1138 --lambdaStackIdx;
1139 break;
1140 }
1141
1142 if(pCell->type == CELL_MACRO)
1143 {
1144 result = evaluateMacro((CELL *)pCell->contents, args->next, newContext);
1145 break;
1146 }
1147
1148 if(pCell->type == CELL_IMPORT_CDECL
1149 #ifdef WIN_32
1150 || pCell->type == CELL_IMPORT_DLL
1151 #endif
1152 )
1153 {
1154 result = executeLibfunction(pCell, args->next);
1155 break;
1156 }
1157
1158 /* check for 'default' functor
1159 * allow function call with context name, i.e: (ctx)
1160 * assumes that a ctx:ctx contains a function
1161 */
1162 if(pCell->type == CELL_CONTEXT)
1163 {
1164 newContext = (SYMBOL *)pCell->contents;
1165 sPtr= translateCreateSymbol(newContext->name, CELL_NIL, newContext, TRUE);
1166 pCell = (CELL *)sPtr->contents;
1167
1168 if(pCell->type == CELL_PRIMITIVE)
1169 {
1170 evalFunc = (CELL *(*)(CELL*))pCell->contents;
1171 result = (*evalFunc)(args->next);
1172 evalFunc = NULL;
1173 break;
1174 }
1175
1176 else if(pCell->type == CELL_LAMBDA)
1177 {
1178 pushLambda(args);
1179 result = evaluateLambda((CELL *)pCell->contents, args->next, newContext);
1180 --lambdaStackIdx;
1181 break;
1182 }
1183
1184 else if(pCell->type == CELL_MACRO)
1185 {
1186 result = evaluateMacro((CELL *)pCell->contents, args->next, newContext);
1187 break;
1188 }
1189
1190 }
1191
1192
1193 /* allow 'implicit indexing' if pCell is a list, array, string or number:
1194 (pCell idx1 idx2 ...)
1195 */
1196
1197 if(args->next != nilCell)
1198 {
1199 if(pCell->type == CELL_EXPRESSION)
1200 result = copyCell(implicitIndexList(pCell, args->next));
1201
1202 else if(pCell->type == CELL_ARRAY)
1203 result = copyCell(implicitIndexArray(pCell, args->next));
1204
1205 else if(pCell->type == CELL_STRING)
1206 result = implicitIndexString(pCell, args->next);
1207
1208 else if(isNumber(pCell->type))
1209 result = implicitNrestSlice(pCell, args->next);
1210
1211 else result = errorProcExt(ERR_INVALID_FUNCTION, cell);
1212 }
1213 else
1214 result = errorProcExt(ERR_INVALID_FUNCTION, cell);
1215 break;
1216
1217 case CELL_DYN_SYMBOL:
1218 return((CELL*)(getDynamicSymbol(cell))->contents);
1219
1220 default:
1221 result = nilCell;
1222 }
1223
1224 while(resultStackIdx > resultIdxSave)
1225 deleteList(popResult());
1226
1227 if(pushResultFlag)
1228 {
1229 if(resultStackIdx > MAX_RESULT_STACK)
1230 fatalError(ERR_OUT_OF_CALL_STACK, pCell, 0);
1231 pushResult(result);
1232 }
1233 else pushResultFlag = TRUE;
1234
1235 if(traceFlag) traceExit(result, cell, pCell, args);
1236 --recursionCount;
1237 return(result);
1238 }
1239
1240
1241 CELL * evaluateExpressionSafe(CELL * cell, int * errNo)
1242 {
1243 jmp_buf errorJumpSave;
1244 CELL * result;
1245
1246 memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
1247 if((*errNo = setjmp(errorJump)) != 0)
1248 {
1249 memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
1250 return(NULL);
1251 }
1252
1253 result = evaluateExpression(cell);
1254 memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
1255 return(result);
1256 }
1257
1258
1259 /* a symbol belonging to a dynamic context */
1260 /* the parent context symbol points to the real context */
1261 /* cell->contents -> name str of this symbol */
1262 /* cell->aux -> symbol var which holds context (dynamic) */
1263 /* ((SYMBOL*)cell->aux)->contents -> context cell */
1264 SYMBOL * getDynamicSymbol(CELL * cell)
1265 {
1266 CELL * contextCell;
1267
1268 contextCell = (CELL *)((SYMBOL *)cell->aux)->contents;
1269 if(contextCell->type != CELL_CONTEXT)
1270 fatalError(ERR_CONTEXT_EXPECTED, stuffSymbol((SYMBOL*)cell->aux), TRUE);
1271
1272 return(translateCreateSymbol(
1273 (char*)cell->contents, /* name of dyn symbol */
1274 CELL_NIL,
1275 (SYMBOL*)contextCell->contents, /* contextPtr */
1276 TRUE));
1277 }
1278
1279
1280 CELL * evalCheckProtected(CELL * cell, CELL * * flagPtr)
1281 {
1282 CELL * result;
1283 SYMBOL * sPtr;
1284
1285 if(isSymbol(cell->type))
1286 {
1287 if(cell->type == CELL_SYMBOL)
1288 sPtr = (SYMBOL *)cell->contents;
1289 else
1290 sPtr = getDynamicSymbol(cell);
1291
1292 if(isProtected(sPtr->flags))
1293 return(errorProcExt(ERR_SYMBOL_PROTECTED, cell));
1294
1295 return((CELL *)sPtr->contents);
1296 }
1297
1298 symbolProtectionLevel = recursionCount;
1299 result = evaluateExpression(cell);
1300 if(symbolProtectionLevel == 0xFFFFFFFF)
1301 {
1302 if(flagPtr == NULL)
1303 return(errorProcExt(ERR_SYMBOL_PROTECTED, cell));
1304 else *flagPtr = cell;
1305 }
1306
1307 symbolProtectionLevel = 0;
1308 return(result);
1309 }
1310
1311
1312 /* -------------------- evaluate lambda function ----------------------- */
1313
1314 CELL * evaluateLambda(CELL * localLst, CELL * arg, SYMBOL * newContext)
1315 {
1316 CELL * local;
1317 CELL * result = nilCell;
1318 CELL * cell;
1319 SYMBOL * symbol;
1320 SYMBOL * contextSave;
1321 int localCount = 0;
1322
1323 if(envStackIdx > (UINT)MAX_ENV_STACK)
1324 return(errorProc(ERR_OUT_OF_ENV_STACK));
1325
1326 if(localLst->type != CELL_EXPRESSION)
1327 return(errorProcExt(ERR_INVALID_LAMBDA, localLst));
1328
1329 /* evaluate arguments */
1330 if(arg != nilCell)
1331 {
1332 /* this symbol precheck does 10% speed improvment on lambdas */
1333 if(arg->type == CELL_SYMBOL)
1334 cell = result = copyCell((CELL*)((SYMBOL *)arg->contents)->contents);
1335 else
1336 cell = result = copyCell(evaluateExpression(arg));
1337
1338 while((arg = arg->next) != nilCell)
1339 {
1340 if(arg->type == CELL_SYMBOL)
1341 cell->next = copyCell((CELL*)((SYMBOL *)arg->contents)->contents);
1342 else
1343 cell->next = copyCell(evaluateExpression(arg));
1344
1345 cell = cell->next;
1346 }
1347 }
1348
1349 /* change to new context */
1350 contextSave = currentContext;
1351 currentContext = newContext;
1352
1353 /* save environment and get parameters */
1354 local = (CELL*)localLst->contents;
1355 GET_LOCAL:
1356 {
1357 if(local->type == CELL_SYMBOL)
1358 symbol = (SYMBOL *)local->contents;
1359 /* get default parameters */
1360 else if(local->type == CELL_EXPRESSION)
1361 {
1362 if(((CELL*)local->contents)->type == CELL_SYMBOL)
1363 {
1364 cell = (CELL *)local->contents;
1365 if(cell->type == CELL_SYMBOL)
1366 {
1367 symbol = (SYMBOL *)cell->contents;
1368 if(result == nilCell)
1369 result = copyCell(evaluateExpression(cell->next));
1370 }
1371 else goto GOT_LOCALS;
1372 }
1373 else goto GOT_LOCALS;
1374 }
1375 else goto GOT_LOCALS;
1376
1377 if(isProtected(symbol->flags))
1378 return(errorProcExt(ERR_SYMBOL_PROTECTED, local));
1379
1380 /* save symbol environment */
1381 pushEnvironment(symbol->contents);
1382 pushEnvironment((UINT)symbol);
1383
1384 /* fill local symbols */
1385 symbol->contents = (UINT)result;
1386 cell = result;
1387 result = result->next;
1388
1389 /* unlink list */
1390 cell->next = nilCell;
1391
1392 local = local->next;
1393 localCount++;
1394 }
1395 goto GET_LOCAL;
1396
1397 GOT_LOCALS:
1398 /* put unassigned args in $args */
1399 pushEnvironment(argsSymbol->contents);
1400 pushEnvironment((UINT)argsSymbol);
1401 argsSymbol->contents = (UINT)getCell(CELL_EXPRESSION);
1402 if(result != nilCell)
1403 ((CELL*)argsSymbol->contents)->contents = (UINT)result;
1404 ++localCount;
1405
1406 /* evaluate body expressions */
1407 cell = localLst->next;
1408 result = nilCell;
1409 while(cell != nilCell)
1410 {
1411 result = evaluateExpression(cell);
1412 cell = cell->next;
1413 }
1414 result = copyCell(result);
1415
1416 /* recover environment of local symbols */
1417 while(localCount--)
1418 {
1419 symbol = (SYMBOL *)popEnvironment();
1420 if(isProtected(symbol->flags) && (symbol != argsSymbol))
1421 symbol->flags &= ~SYMBOL_PROTECTED;
1422 deleteList((CELL *)symbol->contents);
1423 symbol->contents = popEnvironment();
1424 }
1425
1426 currentContext = contextSave;
1427 return(result);
1428 }
1429
1430
1431 CELL * evaluateMacro(CELL * localLst, CELL * arg, SYMBOL * newContext)
1432 {
1433 CELL * local;
1434 CELL * result;
1435 CELL * cell;
1436 SYMBOL * symbol;
1437 SYMBOL * contextSave;
1438 int localCount;
1439
1440 if(envStackIdx > (UINT)MAX_ENV_STACK)
1441 return(errorProc(ERR_OUT_OF_ENV_STACK));
1442
1443 if(localLst->type != CELL_EXPRESSION)
1444 return(errorProcExt(ERR_INVALID_MACRO, localLst));
1445 local = (CELL *)localLst->contents;
1446
1447 contextSave = currentContext;
1448 currentContext = newContext;
1449
1450 /* save environment and get parameters */
1451 localCount = 0;
1452 GET_ARGS:
1453 {
1454 if(local->type == CELL_SYMBOL)
1455 symbol = (SYMBOL *)local->contents;
1456 /* get default parameters */
1457 else if(local->type == CELL_EXPRESSION)
1458 {
1459 if(((CELL*)local->contents)->type == CELL_SYMBOL)
1460 {
1461 cell = (CELL *)local->contents;
1462 if(cell->type == CELL_SYMBOL)
1463 {
1464 symbol = (SYMBOL *)cell->contents;
1465 if(arg == nilCell)
1466 arg = evaluateExpression(cell->next);
1467 }
1468 else goto GOT_ARGS;
1469 }
1470 else goto GOT_ARGS;
1471 }
1472 else goto GOT_ARGS;
1473
1474 if(isProtected(symbol->flags))
1475 return(errorProcExt(ERR_SYMBOL_PROTECTED, local));
1476
1477 pushEnvironment(symbol->contents);
1478 pushEnvironment((UINT)symbol);
1479 symbol->contents = (UINT)copyCell(arg);
1480 local = local->next;
1481 arg = arg->next;
1482 localCount++;
1483 }
1484 goto GET_ARGS;
1485
1486 GOT_ARGS:
1487
1488 pushEnvironment(argsSymbol->contents);
1489 pushEnvironment((UINT)argsSymbol);
1490 argsSymbol->contents = (UINT)getCell(CELL_EXPRESSION);
1491 if(arg != nilCell)
1492 ((CELL*)argsSymbol->contents)->contents = (UINT)copyList(arg);
1493 ++localCount;
1494
1495 arg = localLst->next;
1496 result = nilCell;
1497
1498 while(arg != nilCell)
1499 {
1500 result = evaluateExpression(arg);
1501 arg = arg->next;
1502 }
1503 result = copyCell(result);
1504
1505 while(localCount--)
1506 {
1507 symbol = (SYMBOL *)popEnvironment();
1508 if(isProtected(symbol->flags) && (symbol != argsSymbol))
1509 symbol->flags &= ~SYMBOL_PROTECTED;
1510 deleteList((CELL *)symbol->contents);
1511 symbol->contents = popEnvironment();
1512 }
1513
1514 currentContext = contextSave;
1515 return(result);
1516 }
1517
1518
1519 /* -------------- list/cell creation/deletion routines ---------------- */
1520
1521
1522 CELL * stuffInteger(UINT contents)
1523 {
1524 CELL * cell;
1525
1526 cell = getCell(CELL_LONG);
1527 cell->contents = (UINT) contents;
1528 return(cell);
1529 }
1530
1531 #ifndef NEWLISP64
1532 CELL * stuffInteger64(INT64 contents)
1533 {
1534 CELL * cell;
1535
1536 cell = getCell(CELL_INT64);
1537 *(INT64 *)&cell->aux = contents;
1538 return(cell);
1539 }
1540 #endif
1541
1542
1543 CELL * stuffIntegerList(int argc, ...)
1544 {
1545 CELL * cell;
1546 CELL * list;
1547 va_list ap;
1548
1549 va_start(ap, argc);
1550
1551 list = getCell(CELL_EXPRESSION);
1552 list->contents = (UINT)stuffInteger(va_arg(ap, UINT));
1553 cell = (CELL *)list->contents;
1554
1555 while(--argc)
1556 {
1557 cell->next = stuffInteger(va_arg(ap, UINT));
1558 cell = cell->next;
1559 }
1560 va_end(ap);
1561
1562 return(list);
1563 }
1564
1565
1566 CELL * stuffString(char * string)
1567 {
1568 CELL * cell;
1569
1570 cell = getCell(CELL_STRING);
1571 cell->aux = strlen(string) + 1;
1572 cell->contents = (UINT)allocMemory((UINT)cell->aux);
1573 memcpy((void *)cell->contents, string, (UINT)cell->aux);
1574 return(cell);
1575 }
1576
1577
1578 CELL * stuffStringN(char * string, int len)
1579 {
1580 CELL * cell;
1581
1582 cell = getCell(CELL_STRING);
1583 cell->aux = len + 1;
1584 cell->contents = (UINT)allocMemory((UINT)cell->aux);
1585 memcpy((void *)cell->contents, string, len);
1586 *(char*)(cell->contents + len) = 0;
1587 return(cell);
1588 }
1589
1590 CELL * stuffFloat(double * floatPtr)
1591 {
1592 CELL * cell;
1593
1594 cell = getCell(CELL_FLOAT);
1595 #ifndef NEWLISP64
1596 *(double *)&cell->aux = *floatPtr;
1597 #else
1598 *(double *)&cell->contents = *floatPtr;
1599 #endif
1600 return(cell);
1601 }
1602
1603
1604 CELL * stuffSymbol(SYMBOL * sPtr)
1605 {
1606 CELL * cell;
1607
1608 cell = getCell(CELL_SYMBOL);
1609 cell->contents = (UINT)sPtr;
1610 return(cell);
1611 }
1612
1613 ssize_t convertNegativeOffset(ssize_t offset, CELL * list)
1614 {
1615 int len=0;
1616
1617 while(list != nilCell)
1618 {
1619 ++len;
1620 list = list->next;
1621 }
1622 offset = len + offset;
1623 if(offset < 0)
1624 errorProc(ERR_LIST_INDEX_OUTOF_BOUNDS);
1625 return(offset);
1626 }
1627
1628 /* ------------------------ creating and freeing cells ------------------- */
1629
1630 CELL * getCell(int type)
1631 {
1632 CELL * cell;
1633
1634 if(firstFreeCell == NULL) allocBlock();
1635 cell = firstFreeCell;
1636 firstFreeCell = cell->next;
1637 ++cellCount;
1638
1639 cell->type = type;
1640 cell->next = nilCell;
1641 cell->aux = (UINT)nilCell;
1642 cell->contents = (UINT)nilCell;
1643
1644 return(cell);
1645 }
1646
1647
1648 CELL * copyCell(CELL * cell)
1649 {
1650 CELL * newCell;
1651 UINT len;
1652
1653 if(firstFreeCell == NULL) allocBlock();
1654 newCell = firstFreeCell;
1655 firstFreeCell = newCell->next;
1656 ++cellCount;
1657
1658 newCell->type = cell->type;
1659 newCell->next = nilCell;
1660 newCell->aux = cell->aux;
1661 newCell->contents = cell->contents;
1662
1663 if(isEnvelope(cell->type))
1664 {
1665 if(cell->type == CELL_ARRAY)
1666 newCell->contents = (UINT)copyArray(cell);
1667 else
1668 {
1669 newCell->contents = (UINT)copyList((CELL *)cell->contents);
1670 newCell->aux = (UINT)lastCellCopied; /* last element optimization */
1671 }
1672 }
1673 else if(cell->type == CELL_STRING)
1674 {
1675 newCell->contents = (UINT)allocMemory((UINT)cell->aux);
1676 memcpy((void *)newCell->contents, (void*)cell->contents, (UINT)cell->aux);
1677 }
1678 else if(cell->type == CELL_DYN_SYMBOL)
1679 {
1680 len = strlen((char *)cell->contents);
1681 newCell->contents = (UINT)allocMemory(len + 1);
1682 memcpy((char *)newCell->contents, (char *)cell->contents, len + 1);
1683 }
1684
1685 return(newCell);
1686 }
1687
1688
1689 /* this routine must be called with the list head
1690 if copying with envelope call copyCell() instead */
1691 CELL * copyList(CELL * cell)
1692 {
1693 CELL * firstCell;
1694 CELL * newCell;
1695
1696 if(cell == nilCell || cell == trueCell) return(lastCellCopied = cell);
1697 firstCell = newCell = copyCell(cell);
1698
1699 while((cell = cell->next) != nilCell)
1700 {
1701 newCell->next = copyCell(cell);
1702 newCell = newCell->next;
1703 }
1704
1705 lastCellCopied = newCell;
1706 return(firstCell);
1707 }
1708
1709
1710 /* for deleting lists _and_ cells */
1711 void deleteList(CELL * cell)
1712 {
1713 CELL * next;
1714
1715 while(cell != nilCell)
1716 {
1717 if(isEnvelope(cell->type))
1718 {
1719 if(cell->type == CELL_ARRAY)
1720 deleteArray(cell);
1721 else
1722 deleteList((CELL *)cell->contents);
1723 }
1724
1725 else if(cell->type == CELL_STRING || cell->type == CELL_DYN_SYMBOL)
1726 freeMemory( (void *)cell->contents);
1727
1728 next = cell->next;
1729
1730 /* free cell */
1731 if(cell == trueCell)
1732 {
1733 cell = next;
1734 continue;
1735 }
1736
1737 cell->type = CELL_FREE;
1738 cell->next = firstFreeCell;
1739 firstFreeCell = cell;
1740 --cellCount;
1741
1742 cell = next;
1743 }
1744 }
1745
1746 /* --------------- cell / memory allocation and deallocation ------------- */
1747
1748 CELL * cellMemory = NULL;
1749 CELL * cellBlock = NULL;
1750
1751 void allocBlock()
1752 {
1753 int i;
1754
1755 if(cellCount > MAX_CELL_COUNT) fatalError(ERR_NOT_ENOUGH_MEMORY, NULL, 0);
1756
1757 if(cellMemory == NULL)
1758 {
1759 cellMemory = (CELL *)allocMemory((MAX_BLOCK + 1) * sizeof(CELL));
1760 cellBlock = cellMemory;
1761 }
1762 else
1763 {
1764 (cellBlock + MAX_BLOCK)->next =
1765 (CELL *)allocMemory((MAX_BLOCK + 1) * sizeof(CELL));
1766 cellBlock = (cellBlock + MAX_BLOCK)->next;
1767 }
1768
1769 for(i = 0; i < MAX_BLOCK; i++)
1770 {
1771 (cellBlock + i)->type = CELL_FREE;
1772 (cellBlock + i)->next = (cellBlock + i + 1);
1773 }
1774 (cellBlock + MAX_BLOCK - 1)->next = NULL;
1775 (cellBlock + MAX_BLOCK)->next = NULL;
1776 firstFreeCell = cellBlock;
1777 }
1778
1779
1780 void * allocMemory(size_t nbytes)
1781 {
1782 void * ptr;
1783
1784 if( (ptr = (void *)malloc(nbytes)) == NULL)
1785 fatalError(ERR_NOT_ENOUGH_MEMORY, NULL, 0);
1786
1787 return(ptr);
1788 }
1789
1790 void * callocMemory(size_t nbytes)
1791 {
1792 void * ptr;
1793
1794 if( (ptr = (void *)calloc(nbytes, 1)) == NULL)
1795 fatalError(ERR_NOT_ENOUGH_MEMORY, NULL, 0);
1796
1797 return(ptr);
1798 }
1799
1800 void * reallocMemory(void * prevPtr, UINT size)
1801 {
1802 void * ptr;
1803
1804 if( (ptr = realloc(prevPtr, size)) == NULL)
1805 fatalError(ERR_NOT_ENOUGH_MEMORY, NULL, 0);
1806
1807 return(ptr);
1808 }
1809
1810 /* ----------- garbage collection , only required on error --------------- */
1811
1812 void markReferences(SYMBOL * sPtr);
1813 void markList(CELL * cell);
1814 void sweepGarbage(void);
1815 void relinkCells(void);
1816
1817
1818 void collectGarbage()
1819 {
1820 resultStackIdx = 0;
1821 nilCell->type |= (UINT)0x00008000;
1822 markReferences((SYMBOL *)((CELL *)mainContext->contents)->aux);
1823 sweepGarbage();
1824 relinkCells();
1825 }
1826
1827
1828 void markReferences(SYMBOL * sPtr)
1829 {
1830 CELL * content;
1831
1832 if(sPtr != NIL_SYM && sPtr != NULL)
1833 {
1834 markReferences(sPtr->left);
1835 markList((CELL *)sPtr->contents);
1836 if((symbolType(sPtr) & 0xFF) == CELL_CONTEXT && sPtr != mainContext)
1837 {
1838 content = (CELL *)sPtr->contents;
1839 if((SYMBOL*)content->contents != mainContext && (SYMBOL*)content->contents == sPtr)
1840 markReferences((SYMBOL *)content->aux);
1841 }
1842 markReferences(sPtr->right);
1843 }
1844 }
1845
1846
1847 void markList(CELL * cell)
1848 {
1849 while(cell != nilCell)
1850 {
1851 cell->type |= (UINT)0x00008000;
1852 if(isEnvelope(cell->type & RAW_TYPE_MASK))
1853 {
1854 if((RAW_TYPE_MASK & cell->type) == CELL_ARRAY)
1855 markArray(cell);
1856 else
1857 markList((CELL *)cell->contents);
1858 }
1859 cell = cell->next;
1860 }
1861 }
1862
1863
1864 void sweepGarbage()
1865 {
1866 CELL * blockPtr;
1867 CELL * lastBlockPtr;
1868 CELL * memPtr;
1869 int i, freed;
1870
1871 lastBlockPtr = blockPtr = cellMemory;
1872 while(blockPtr != NULL)
1873 {
1874 for(i = freed = 0; i < MAX_BLOCK; i++)
1875 {
1876 if(*(UINT *)blockPtr != CELL_FREE)
1877 {
1878 if( *(UINT *)blockPtr & (UINT)0x00008000)
1879 *(UINT *)blockPtr &= (UINT)0x00007FFF;
1880 else
1881 {
1882 blockPtr->type = CELL_FREE;
1883 --cellCount;
1884 freed++;
1885 }
1886 }
1887 else freed++;
1888 blockPtr++;
1889 }
1890 if(freed == MAX_BLOCK)
1891 {
1892 memPtr = blockPtr->next;
1893 freeMemory(lastBlockPtr->next);
1894 lastBlockPtr->next = memPtr;
1895 blockPtr = memPtr;
1896 }
1897 else
1898 {
1899 lastBlockPtr = blockPtr;
1900 blockPtr = blockPtr->next;
1901 }
1902 }
1903 }
1904
1905
1906 void relinkCells(void)
1907 {
1908 CELL * blockPtr;
1909 CELL * lastFreeCell = NULL;
1910 int i;
1911
1912 cellBlock = blockPtr = cellMemory;
1913 firstFreeCell = NULL;
1914 while(blockPtr != NULL)
1915 {
1916 cellBlock = blockPtr;
1917 for(i = 0; i < MAX_BLOCK; i++)
1918 {
1919 if(*(UINT *)blockPtr == CELL_FREE)
1920 {
1921 if(firstFreeCell == NULL)
1922 firstFreeCell = lastFreeCell = blockPtr;
1923 else
1924 {
1925 lastFreeCell->next = blockPtr;
1926 lastFreeCell = blockPtr;
1927 }
1928 }
1929 ++blockPtr;
1930 }
1931 blockPtr = blockPtr->next;
1932 }
1933 lastFreeCell->next = NULL;
1934 }
1935
1936
1937 void cleanupResults(int from)
1938 {
1939 while(resultStackIdx > from)
1940 deleteList(popResult());
1941 }
1942
1943 /* -------------------------- I/O routines ------------------------------ */
1944
1945 UINT printDevice;
1946 STREAM errorStream;
1947 void prettyPrint(UINT device);
1948
1949 void varPrintf(UINT device, char * format, ...)
1950 {
1951 char * buffer;
1952 va_list argptr;
1953
1954 va_start(argptr,format);
1955
1956 /* new in 7201 , defined in nl-filesys.c if not in libc */
1957 vasprintf(&buffer, format, argptr);
1958
1959 prettyPrintLength += strlen(buffer);
1960 switch(device)
1961 {
1962 case OUT_NULL:
1963 return;
1964 case OUT_DEVICE:
1965 if(printDevice != 0)
1966 {
1967 write(printDevice, buffer, strlen(buffer));
1968 break;
1969 }
1970 case OUT_CONSOLE:
1971 #ifdef LIBRARY
1972 writeStreamStr(&libStrStream, buffer, 0);
1973 return;
1974 #else
1975 if(IOchannel == stdin)
1976 {
1977 printf("%s", buffer);
1978 if(!isTTY) fflush(NULL);
1979 }
1980 else
1981 {
1982 if(IOchannel != NULL)
1983 #ifndef WIN_32
1984 fprintf(IOchannel, "%s", buffer);
1985 #else
1986 fprintf(IOchannel, buffer);
1987 #endif
1988 }
1989 break;
1990 #endif
1991 case OUT_LOG:
1992 writeLog(buffer, 0);
1993 break;
1994 default:
1995 writeStreamStr((STREAM *)device, buffer, 0);
1996 break;
1997 }
1998
1999 freeMemory(buffer);
2000
2001 va_end(argptr);
2002 }
2003
2004
2005 int printCell(CELL * cell, UINT printFlag, UINT device)
2006 {
2007 SYMBOL * sPtr;
2008 SYMBOL * sp;
2009
2010 switch(cell->type)
2011 {
2012 case CELL_NIL:
2013 varPrintf(device, "nil"); break;
2014
2015 case CELL_TRUE:
2016 varPrintf(device, "true"); break;
2017
2018 case CELL_LONG:
2019 varPrintf(device,"%ld", cell->contents); break;
2020
2021 #ifndef NEWLISP64
2022 case CELL_INT64:
2023 #ifdef TRU64
2024 varPrintf(device,"%ld", *(INT64 *)&cell->aux); break;
2025 #else
2026 #ifdef WIN_32
2027 varPrintf(device,"%I64d", *(INT64 *)&cell->aux); break;
2028 #else
2029 varPrintf(device,"%lld", *(INT64 *)&cell->aux); break;
2030 #endif
2031 #endif
2032 #endif
2033 case CELL_FLOAT:
2034 #ifndef NEWLISP64
2035 varPrintf(device,"%1.10g",*(double *)&cell->aux);
2036 #else
2037 varPrintf(device,"%1.10g",*(double *)&cell->contents);
2038 #endif
2039 break;
2040
2041 case CELL_STRING:
2042 if(printFlag)
2043 printString((char *)cell->contents, device, cell->aux - 1);
2044 else
2045 varPrintf(device,"%s",cell->contents);
2046 break;
2047
2048 case CELL_SYMBOL:
2049 case CELL_CONTEXT:
2050 sPtr = (SYMBOL *)cell->contents;
2051 if(sPtr->context != currentContext
2052 /* if not global or global overwritten in current context */
2053 && (!(sPtr->flags & SYMBOL_GLOBAL) || (lookupSymbol(sPtr->name, currentContext)))
2054 && (symbolType(sPtr) != CELL_CONTEXT ||
2055 (SYMBOL *)((CELL*)sPtr->contents)->contents != sPtr)) /* context var */
2056 {
2057 varPrintf(device,"%s:%s", (char*)((SYMBOL*)sPtr->context)->name, sPtr->name);
2058 break;
2059 }
2060 /* overwriting global in MAIN */
2061 if(sPtr->context == currentContext
2062 && currentContext != mainContext
2063 && ((sp = lookupSymbol(sPtr->name, mainContext)) != NULL)
2064 && (sp->flags & SYMBOL_GLOBAL) )
2065 {
2066 varPrintf(device,"%s:%s", currentContext->name, sPtr->name);
2067 break;
2068 }
2069
2070 varPrintf(device,"%s",sPtr->name);
2071 break;
2072
2073 case CELL_PRIMITIVE:
2074 case CELL_IMPORT_CDECL:
2075 #ifdef WIN_32
2076 case CELL_IMPORT_DLL:
2077 #endif
2078 varPrintf(device,"%s <%lX>", (char *)cell->aux, cell->contents);
2079 break;
2080
2081 case CELL_QUOTE:
2082 varPrintf(device, "'");
2083 prettyPrintFlags |= PRETTYPRINT_DOUBLE;
2084 printCell((CELL *)cell->contents, printFlag, device);
2085 break;
2086
2087 case CELL_EXPRESSION:
2088 case CELL_LAMBDA:
2089 case CELL_MACRO:
2090 printExpression(cell, device);
2091 break;
2092
2093 case CELL_DYN_SYMBOL:
2094 varPrintf(device, "%s:%s", ((SYMBOL*)cell->aux)->name, (char*)cell->contents);
2095 break;
2096 case CELL_ARRAY:
2097 printArray(cell, device);
2098 break;
2099
2100 default:
2101 varPrintf(device,"?");
2102 }
2103
2104 prettyPrintFlags &= ~PRETTYPRINT_DOUBLE;
2105 return(1);
2106 }
2107
2108
2109 void printString(char * str, UINT device, int size)
2110 {
2111 char chr;
2112
2113 if(size >= MAX_STRING)
2114 {
2115 varPrintf(device, "[text]");
2116 while(size--) varPrintf(device, "%c", *str++);
2117 varPrintf(device, "[/text]");
2118 return;
2119 }
2120
2121 varPrintf(device,"\"");
2122 while(size--)
2123 {
2124 switch(chr = *str++)
2125 {
2126 case '\n': varPrintf(device,"\\n"); break;
2127 case '\r': varPrintf(device,"\\r"); break;
2128 case '\t': varPrintf(device,"\\t"); break;
2129 case '\\': varPrintf(device,"\\\\"); break;
2130 case '"': varPrintf(device,"\\%c",'"'); break;
2131 default:
2132 if((unsigned char)chr < 32 || (stringOutputRaw && (unsigned char)chr > 126))
2133 varPrintf(device,"\\%03u", (unsigned char)chr);
2134 else
2135 varPrintf(device,"%c",chr); break;
2136 }
2137 }
2138 varPrintf(device,"\"");
2139 }
2140
2141
2142 int printExpression(CELL * cell, UINT device)
2143 {
2144 CELL * item;
2145 int i, pFlags;
2146
2147 item = (CELL *)cell->contents;
2148
2149
2150 if(prettyPrintPars <= prettyPrintCurrent ||
2151 prettyPrintLength > prettyPrintMaxLength)
2152 prettyPrint(device);
2153
2154 if(cell->type == CELL_LAMBDA)
2155 {
2156 varPrintf(device, "(lambda ");
2157 ++prettyPrintPars;
2158 }
2159 else if(cell->type == CELL_MACRO)
2160 {
2161 varPrintf(device, "(lambda-macro ");
2162 ++prettyPrintPars;
2163 }
2164 else
2165 {
2166 if(isSymbol(item->type))
2167 {
2168 if(item->type == CELL_SYMBOL)
2169 pFlags = ((SYMBOL *)item->contents)->flags;
2170 else
2171 pFlags = 0;
2172
2173 if((pFlags & PRINT_TYPE_MASK) != 0)
2174 {
2175 prettyPrint(device);
2176 varPrintf(device, "(");
2177 ++prettyPrintPars;
2178 for(i = 0; i < (pFlags & PRINT_TYPE_MASK); i++)
2179 {
2180 if(item == nilCell)
2181 {prettyPrintFlags |= PRETTYPRINT_DOUBLE; break;}
2182 printCell(item, TRUE, device);
2183 item = item->next;
2184 if(item != nilCell) varPrintf(device," ");
2185 else prettyPrintFlags |= PRETTYPRINT_DOUBLE;
2186 }
2187 prettyPrint(device);
2188 }
2189 else
2190 {
2191 varPrintf(device, "(");
2192 ++prettyPrintPars;
2193 }
2194 }
2195 else
2196 {
2197 varPrintf(device, "(");
2198 ++prettyPrintPars;
2199 }
2200 }
2201
2202
2203 while(item != nilCell)
2204 {
2205 if(prettyPrintLength > prettyPrintMaxLength) prettyPrint(device);
2206 if(printCell(item, TRUE, device) == 0) return(0);
2207 item = item->next;
2208 if(item != nilCell) varPrintf(device," ");
2209 }
2210
2211 varPrintf(device,")");
2212 --prettyPrintPars;
2213
2214 return(TRUE);
2215 }
2216
2217
2218 void prettyPrint(UINT device)
2219 {
2220 int i;
2221
2222 if(prettyPrintFlags) return;
2223
2224 if(prettyPrintPars > 0)
2225 varPrintf(device, LINE_FEED);
2226 /* varPrintf(device, LINE_FEED); before 7106 */
2227
2228 for(i = 0; i < prettyPrintPars; i++)
2229 varPrintf(device, prettyPrintTab);
2230 prettyPrintLength = prettyPrintCurrent = prettyPrintPars;
2231 prettyPrintFlags |= PRETTYPRINT_DOUBLE;
2232 }
2233
2234
2235 void printSymbol(SYMBOL * sPtr, UINT device)
2236 {
2237 CELL * cell;
2238 CELL * list = NULL;
2239 char * setStr;
2240
2241 prettyPrintCurrent = prettyPrintPars = 1;
2242 prettyPrintLength = 0;
2243 prettyPrintFlags &= !PRETTYPRINT_DOUBLE;
2244
2245 if(sPtr->flags & SYMBOL_PROTECTED)
2246 setStr = "(constant ";
2247 else
2248 setStr = "(set ";
2249
2250 switch(symbolType(sPtr))
2251 {
2252 case CELL_PRIMITIVE:
2253 case CELL_IMPORT_CDECL:
2254 #ifdef WIN_32
2255 case CELL_IMPORT_DLL:
2256 #endif
2257 break;
2258 case CELL_SYMBOL:
2259 case CELL_DYN_SYMBOL:
2260 varPrintf(device, setStr);
2261 printSymbolNameExt(device, sPtr);
2262 varPrintf(device,"'");
2263 printCell((CELL *)sPtr->contents, TRUE, device);
2264 varPrintf(device, ")");
2265 break;
2266 case CELL_ARRAY:
2267 case CELL_EXPRESSION:
2268 varPrintf(device, setStr);
2269 printSymbolNameExt(device, sPtr);
2270 cell = (CELL *)sPtr->contents;
2271
2272 if(symbolType(sPtr) == CELL_ARRAY)
2273 {
2274 varPrintf(device, "(array ");
2275 printArrayDimensions(cell, device);
2276 varPrintf(device, "(flat ");
2277 list = cell = arrayList(cell);
2278 }
2279
2280 cell = (CELL *)cell->contents;
2281
2282 varPrintf(device,"'(");
2283 prettyPrintPars = 2;
2284 if(cell->type == CELL_EXPRESSION) prettyPrint(device);
2285 while(cell != nilCell)
2286 {
2287 if(prettyPrintLength > prettyPrintMaxLength)
2288 prettyPrint(device);
2289 printCell(cell, TRUE, device);
2290 cell = cell->next;
2291 if(cell != nilCell) varPrintf(device, " ");
2292 }
2293 varPrintf(device, "))");
2294 if(symbolType(sPtr) == CELL_ARRAY)
2295 {
2296 deleteList(list);
2297 varPrintf(device ,"))");
2298 }
2299 break;
2300 case CELL_LAMBDA:
2301 case CELL_MACRO:
2302 if(isProtected(sPtr->flags))
2303 {
2304 varPrintf(device, "%s%s%s", LINE_FEED, LINE_FEED, setStr);
2305 printSymbolNameExt(device, sPtr);
2306 printExpression((CELL *)sPtr->contents, device);
2307 varPrintf(device, ")");
2308 }
2309 else if (isGlobal(sPtr->flags))
2310 {
2311 printLambda(sPtr, device);
2312 varPrintf(device, "%s%s", LINE_FEED, LINE_FEED);
2313 printSymbolNameExt(device, sPtr);
2314 }
2315 else printLambda(sPtr, device);
2316 break;
2317 default:
2318 varPrintf(device, setStr);
2319 printSymbolNameExt(device, sPtr);
2320 printCell((CELL *)sPtr->contents, TRUE, device);
2321 varPrintf(device, ")");
2322 break;
2323 }
2324
2325 varPrintf(device, "%s%s", LINE_FEED, LINE_FEED);
2326
2327 prettyPrintLength = prettyPrintPars = 0;
2328 }
2329
2330
2331 void printLambda(SYMBOL * sPtr, UINT device)
2332 {
2333 CELL * lambda;
2334 CELL * cell;
2335
2336 lambda = (CELL *)sPtr->contents;
2337 cell = (CELL *)lambda->contents;
2338 if(cell->type == CELL_EXPRESSION)
2339 cell = (CELL *)cell->contents;
2340
2341 if(!isLegalSymbol(sPtr->name))
2342 {
2343 varPrintf(device, "(set (sym ");
2344 printString(sPtr->name, device, strlen(sPtr->name));
2345 varPrintf(device, " %s) ", ((SYMBOL*)sPtr->context)->name);
2346 printExpression((CELL *)sPtr->contents, device);
2347 varPrintf(device, ")");
2348 return;
2349 }
2350
2351 if(symbolType(sPtr) == CELL_LAMBDA)
2352 varPrintf(device, "(define (");
2353 else
2354 varPrintf(device, "(define-macro (");
2355 prettyPrintPars += 2;
2356
2357 printSymbolName(device, sPtr);
2358 varPrintf(device, " ");
2359
2360 while(cell != nilCell)
2361 {
2362 printCell(cell, TRUE, device);
2363 cell = cell->next;
2364 if(cell != nilCell) varPrintf(device, " ");
2365 }
2366 varPrintf(device, ")");
2367 --prettyPrintPars;
2368 prettyPrint(device);
2369
2370 cell = (CELL *)lambda->contents;
2371 while((cell = cell->next) != nilCell)
2372 {
2373 if(prettyPrintLength > prettyPrintMaxLength) prettyPrint(device);
2374 printCell(cell, TRUE, device);
2375 if(!(cell->type & ENVELOPE_TYPE_MASK) && cell->next != nilCell) varPrintf(device, " ");
2376 }
2377
2378 varPrintf(device, ")");
2379 --prettyPrintPars;
2380 }
2381
2382
2383 void printSymbolName(UINT device, SYMBOL * sPtr)
2384 {
2385 SYMBOL * sp;
2386
2387 if(sPtr->context == currentContext)
2388 {
2389 if(*sPtr->name == *currentContext->name && strcmp(sPtr->name, currentContext->name) == 0)
2390 varPrintf(device, "%s:%s", sPtr->name, sPtr->name);
2391
2392 else if(currentContext != mainContext
2393 && ((sp = lookupSymbol(sPtr->name, mainContext)) != NULL)
2394 && (sp->flags & SYMBOL_GLOBAL) )
2395 varPrintf(device, "%s:%s", currentContext->name, sPtr->name);
2396 else
2397 varPrintf(device,"%s", sPtr->name);
2398 }
2399 else
2400 varPrintf(device,"%s:%s",
2401 (char *)((SYMBOL*)sPtr->context)->name, sPtr->name);
2402 }
2403
2404
2405 void printSymbolNameExt(UINT device, SYMBOL * sPtr)
2406 {
2407 if(isGlobal(sPtr->flags))
2408 {
2409 varPrintf(device, "(global '");
2410 printSymbolName(device, sPtr);
2411 if(symbolType(sPtr) == CELL_LAMBDA || symbolType(sPtr) == CELL_MACRO)
2412 varPrintf(device, ")");
2413 else varPrintf(device, ") ");
2414 }
2415 else
2416 {
2417 if(!isLegalSymbol(sPtr->name))
2418 {
2419 varPrintf(device, " (sym ");
2420 printString(sPtr->name, device, strlen(sPtr->name));
2421 varPrintf(device, " %s) ", ((SYMBOL*)sPtr->context)->name);
2422 }
2423 else
2424 {
2425 varPrintf(device, "'");
2426 printSymbolName(device, sPtr);
2427 }
2428 varPrintf(device, " ");
2429 }
2430 }
2431
2432
2433 CELL * p_prettyPrint(CELL * params)
2434 {
2435 CELL * result;
2436 char * str;
2437 size_t len;
2438
2439 if(params != nilCell)
2440 params = getInteger(params, &prettyPrintMaxLength);
2441 if(params != nilCell)
2442 {
2443 getStringSize(params, &str, &len, TRUE);
2444 prettyPrintTab = allocMemory(len + 1);
2445 memcpy(prettyPrintTab, str, len + 1);
2446 }
2447
2448 result = getCell(CELL_EXPRESSION);
2449 result->contents = (UINT)stuffInteger(prettyPrintMaxLength);
2450 ((CELL *)result->contents)->next = stuffString(prettyPrintTab);
2451
2452 return(result);
2453 }
2454
2455
2456
2457 /* -------------------------- error handling --------------------------- */
2458
2459 char * errorMessage[] =
2460 {
2461 "", /* 0 */
2462 "not enough memory", /* 1 */
2463 "environment stack overflow", /* 2 */
2464 "call stack overflow", /* 3 */
2465 "problem accessing file", /* 4 */
2466 "not an expression", /* 5 */
2467 "missing parenthesis", /* 6 */
2468 "string token too long", /* 7 */
2469 "missing argument", /* 8 */
2470 "number or string expected", /* 9 */
2471 "value expected", /* 10 */
2472 "string expected", /* 11 */
2473 "symbol expected", /* 12 */
2474 "context expected", /* 13 */
2475 "symbol or context expected", /* 14 */
2476 "list expected", /* 15 */
2477 "list or array expected", /* 15 */
2478 "list or symbol expected", /* 17 */
2479 "list or string expected", /* 18 */
2480 "list or number expected", /* 19 */
2481 "array expected", /* 20 */
2482 "array, list or string expected", /* 21 */
2483 "lambda expected", /* 22 */
2484 "lambda-macro expected", /* 23 */
2485 "invalid function", /* 24 */
2486 "invalid lambda expression", /* 25 */
2487 "invalid macro expression", /* 26 */
2488 "invalid let parameter list", /* 27 */
2489 "problem saving file", /* 28 */
2490 "division by zero", /* 29 */
2491 "matrix expected", /* 30 */
2492 "wrong dimensions", /* 31 */
2493 "matrix is singular", /* 32 */
2494 "syntax in regular expression", /* 33 */
2495 "throw without catch", /* 34 */
2496 "problem loading library", /* 35 */
2497 "import function not found", /* 36 */
2498 "symbol is protected", /* 37 */
2499 "number out of range", /* 38 */
2500 "regular expression", /* 39 */
2501 "missing end of text [/text]", /* 40 */
2502 "mismatch in number of arguments", /* 41 */
2503 "problem in format string", /* 42 */
2504 "data type and format don't match", /* 43 */
2505 "invalid parameter", /* 44 */
2506 "invalid parameter: 0.0", /* 45 */
2507 "invalid parameter: NaN", /* 46 */
2508 "illegal parameter type", /* 47 */
2509 "symbol not in MAIN context", /* 48 */
2510 "symbol not in current context", /* 49 */
2511 "target cannot be MAIN", /* 50 */
2512 "list index out of bounds", /* 51 */
2513 "array index out of bounds", /* 52 */
2514 "string index out of bounds", /* 53 */
2515 "nesting level to deep", /* 54 */
2516 "invalid syntax", /* 55 */
2517 "user error", /* 56 */
2518 "user reset -", /* 57 */
2519 "received SIGINT -", /* 58 */
2520 "function is not reentrant" /* 59 */
2521 };
2522
2523
2524 void errorMissingPar(STREAM * stream)
2525 {
2526 char str[64];
2527 snprintf(str, 40, "...%-40s", ((char *)((stream->ptr - stream->buffer) > 40 ? stream->ptr - 40 : stream->buffer)));
2528 errorProcExt2(ERR_MISSING_PAR, stuffString(str));
2529 }
2530
2531 CELL * errorProcAll(int errorNumber, CELL * expr, int deleteFlag)
2532 {
2533 if(!traceFlag) fatalError(errorNumber, expr, deleteFlag);
2534 printErrorMessage(errorNumber, expr, deleteFlag);
2535 openTrace();
2536 return(nilCell);
2537 }
2538
2539 CELL * errorProc(int errorNumber)
2540 {
2541 return(errorProcAll(errorNumber, NULL, 0));
2542 }
2543
2544 /* extended error info in expr */
2545 CELL * errorProcExt(int errorNumber, CELL * expr)
2546 {
2547 return(errorProcAll(errorNumber, expr, 0));
2548 }
2549
2550 /* extended error info in expr, which has to be discarded after printing */
2551 CELL * errorProcExt2(int errorNumber, CELL * expr)
2552 {
2553 return(errorProcAll(errorNumber, expr, 1));
2554 }
2555
2556 CELL * errorProcArgs(int errorNumber, CELL * expr)
2557 {
2558 if(expr == nilCell)
2559 return(errorProcExt(ERR_MISSING_ARGUMENT, NULL));
2560
2561 return(errorProcExt(errorNumber, expr));
2562 }
2563
2564 void fatalError(int errorNumber, CELL * expr, int deleteFlag)
2565 {
2566 printErrorMessage(errorNumber, expr, deleteFlag);
2567 closeTrace();
2568 longjmp(errorJump, errorReg);
2569 }
2570
2571
2572 void printErrorMessage(UINT errorNumber, CELL * expr, int deleteFlag)
2573 {
2574 CELL * lambdaFunc;
2575 UINT lambdaStackIdxSave;
2576 SYMBOL * context;
2577 int i;
2578
2579 if(errorNumber == EXCEPTION_THROW)
2580 errorNumber = ERR_THROW_WO_CATCH;
2581
2582 errorReg = errorNumber;
2583
2584 if(!errorNumber) return;
2585
2586 openStrStream(&errorStream, MAX_STRING, 1);
2587 if(traceFlag & ~TRACE_SIGINT) writeStreamStr(&errorStream, "ERR:", 4);
2588 writeStreamStr(&errorStream, errorMessage[errorReg], 0);
2589
2590 for(i = 0; primitive[i].name != NULL; i++)
2591 {
2592 if(evalFunc == primitive[i].function)
2593 {
2594 writeStreamStr(&errorStream, " in function ", 0);
2595 writeStreamStr(&errorStream, primitive[i].name, 0);
2596 break;
2597 }
2598 }
2599
2600 if(expr != NULL)
2601 {
2602 writeStreamStr(&errorStream, " : ", 3);
2603 printCell(expr, (errorNumber != ERR_USER_ERROR), (UINT)&errorStream);
2604 if(deleteFlag) deleteList(expr);
2605 }
2606
2607 lambdaStackIdxSave = lambdaStackIdx;
2608 while(lambdaStackIdx)
2609 {
2610 lambdaFunc = popLambda();
2611 if(lambdaFunc->type == CELL_SYMBOL)
2612 {
2613 writeStreamStr(&errorStream, LINE_FEED, 0);
2614 writeStreamStr(&errorStream, "called from user defined function ", 0);
2615 context = ((SYMBOL *)lambdaFunc->contents)->context;
2616 if(context != mainContext)
2617 {
2618 writeStreamStr(&errorStream, context->name, 0);
2619 writeStreamStr(&errorStream, ":", 0);
2620 }
2621 writeStreamStr(&errorStream, ((SYMBOL *)lambdaFunc->contents)->name, 0);
2622 }
2623 }
2624 lambdaStackIdx = lambdaStackIdxSave;
2625
2626
2627 if(!(traceFlag & TRACE_SIGINT)) evalFunc = NULL;
2628 parStackCounter = prettyPrintPars = 0;
2629
2630 if(evalCatchFlag && !(traceFlag & TRACE_SIGINT)) return;
2631
2632 if(errorEvent == nilSymbol)
2633 {
2634 if(errorNumber == ERR_SIGINT)
2635 printf(errorStream.buffer);
2636 else
2637 varPrintf(OUT_CONSOLE, "\n%.1024s\n", errorStream.buffer);
2638 }
2639 }
2640
2641
2642 /* --------------------------- load source file ------------------------- */
2643
2644
2645 CELL * loadFile(char * fileName, UINT offset, int encryptFlag, SYMBOL * context)
2646 {
2647 CELL * result;
2648 STREAM stream;
2649 int errNo, dataLen;
2650 jmp_buf errorJumpSave;
2651 SYMBOL * contextSave;
2652 char key[16];
2653 #ifdef LOAD_DEBUG
2654 int i;
2655 #endif
2656
2657 contextSave = currentContext;
2658 currentContext = context;
2659 if(encryptFlag)
2660 {
2661 dataLen = *((int *) (linkOffset + 4));
2662 snprintf( key, 15, "%d", dataLen);
2663 }
2664 else dataLen = MAX_FILE_BUFFER;
2665
2666 if(my_strnicmp(fileName, "http://", 7) == 0)
2667 {
2668 result = getPutPostDeleteUrl(fileName, nilCell, HTTP_GET_URL, 60000);
2669 pushResult(result);
2670 if(memcmp((char *)result->contents, "ERR:", 4) == 0)
2671 return(errorProcExt2(ERR_ACCESSING_FILE, stuffString((char *)result->contents)));
2672 return(copyCell(sysEvalString((char *)result->contents, nilCell, context)));
2673 }
2674
2675 if(my_strnicmp(fileName, "file://", 7) == 0)
2676 fileName = fileName + 7;
2677
2678 if(makeStreamFromFile(&stream, fileName, dataLen + 4 * MAX_STRING, offset) == 0)
2679 return(NULL);
2680
2681 if(encryptFlag)
2682 encryptPad(stream.buffer, stream.buffer, key, dataLen, strlen(key));
2683
2684 memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
2685 if((errNo = setjmp(errorJump)) != 0)
2686 {
2687 closeStrStream(&stream);
2688 memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
2689 currentContext = contextSave;
2690 longjmp(errorJump, errNo);
2691 }
2692
2693 #ifdef LOAD_DEBUG
2694 for(i = 0; i<recursionCount; i++) printf(" ");
2695 printf("load: %s\n", fileName);
2696 #endif
2697
2698 result = evaluateStream(&stream, 0, TRUE);
2699 currentContext = contextSave;
2700
2701 #ifdef LOAD_DEBUG
2702 for(i = 0; i<recursionCount; i++) printf(" ");
2703 printf("finish load: %s\n", fileName);
2704 #endif
2705
2706 memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
2707 closeStrStream(&stream);
2708 return(result);
2709 }
2710
2711 /* -------------------------- parse / compile ----------------------------- */
2712
2713
2714 int compileExpression(STREAM * stream, CELL * cell)
2715 {
2716 char token[MAX_STRING + 4];
2717 double floatNumber;
2718 CELL * newCell;
2719 CELL * contextCell;
2720 SYMBOL * contextPtr;
2721 int listFlag, tklen;
2722 char * lastPtr;
2723 #if experimental
2724 SYMBOL * saveContext;
2725 int defaultSymbolLevel = 0;
2726
2727 saveContext = currentContext;
2728 #endif
2729
2730 listFlag = TRUE; /* assumes we just entered from an envelope cell ! */
2731
2732 GETNEXT:
2733 lastPtr = stream->ptr;
2734 switch(getToken(stream, token, &tklen))
2735 {
2736 case TKN_ERROR:
2737 errorProcExt2(ERR_EXPRESSION, stuffStringN(lastPtr,
2738 (strlen(lastPtr) < 60) ? strlen(lastPtr) : 60));
2739 return(0);
2740
2741 case TKN_EMPTY:
2742 if(parStackCounter != 0) errorMissingPar(stream);
2743 return(0);
2744
2745 case TKN_CHARACTER:
2746 newCell = stuffInteger((UINT)token[0]);
2747 break;
2748
2749 case TKN_HEX:
2750 #ifndef NEWLISP64
2751 newCell = stuffInteger64((INT64)strtoull(token,NULL,0));
2752 #else
2753 newCell = stuffInteger(strtoull(token,NULL,0));
2754 #endif
2755 break;
2756
2757 case TKN_DECIMAL:
2758 #ifndef NEWLISP64
2759 newCell = stuffInteger64(strtoll(token,NULL,0));
2760 #else
2761 newCell = stuffInteger(strtoll(token,NULL,0));
2762 #endif
2763 break;
2764
2765 case TKN_FLOAT:
2766 floatNumber = (double)atof(token);
2767 newCell = stuffFloat(&floatNumber);
2768 break;
2769
2770 case TKN_STRING:
2771 newCell = stuffStringN(token, tklen);
2772 break;
2773
2774 case TKN_SYMBOL:
2775 if(strcmp(token, "lambda") == 0 || strcmp(token, "fn") == 0)
2776 {
2777 if(cell->type != CELL_EXPRESSION)
2778 {
2779 errorProcExt2(ERR_INVALID_LAMBDA, stuffString(lastPtr));
2780 return(0);
2781 }
2782 cell->type = CELL_LAMBDA;
2783 cell->aux = (UINT)nilCell;
2784 goto GETNEXT;
2785 }
2786 else if(strcmp(token, "lambda-macro") == 0 || strcmp(token, "fn-macro") == 0)
2787 {
2788 if(cell->type != CELL_EXPRESSION)
2789 {
2790 errorProcExt2(ERR_INVALID_LAMBDA, stuffString(lastPtr));
2791 return(0);
2792 }
2793 cell->type = CELL_MACRO;
2794 cell->aux = (UINT)nilCell;
2795 goto GETNEXT;
2796 }
2797
2798 else if(strncmp(token, "[text]", 6) == 0)
2799 {
2800 newCell = getCell(CELL_STRING);
2801 newCell->contents = (UINT)readStreamText(stream, "[/text]");
2802 if(newCell->contents == 0)
2803 {
2804 deleteList(newCell);
2805 errorProc(ERR_MISSING_TEXT_END);
2806 }
2807 newCell->aux = strlen((char *)newCell->contents) + 1;
2808 newCell->type = CELL_STRING;
2809 break;
2810 }
2811 newCell = getCell(CELL_SYMBOL);
2812 if(*token == '$')
2813 newCell->contents = (UINT)translateCreateSymbol(
2814 token, CELL_NIL, mainContext, TRUE);
2815 else
2816 newCell->contents = (UINT)translateCreateSymbol(
2817 token, CELL_NIL, currentContext, 0);
2818 break;
2819
2820 case TKN_CONTEXT:
2821 contextPtr = NULL; /* since 7.5.1 dyna vars inside contexts */
2822 if(currentContext != mainContext)
2823 {
2824 if(strcmp(currentContext->name, token) == 0)
2825 contextPtr = currentContext;
2826 else
2827 contextPtr = lookupSymbol(token, currentContext);
2828 }
2829
2830 if(contextPtr == NULL)
2831 {
2832 contextPtr = translateCreateSymbol(
2833 token, CELL_CONTEXT, mainContext, TRUE);
2834 }
2835
2836 contextCell = (CELL *)contextPtr->contents;
2837
2838 if(getToken(stream, token, &tklen) != TKN_SYMBOL)
2839 errorProcExt2(ERR_SYMBOL_EXPECTED, stuffString(lastPtr));
2840
2841 /* context does not exist */
2842 if(contextCell->type != CELL_CONTEXT
2843 || contextPtr != (SYMBOL*)contextCell->contents)
2844 {
2845 newCell = getCell(CELL_DYN_SYMBOL);
2846 newCell->aux = (UINT)contextPtr;
2847 newCell->contents = (UINT)allocMemory(tklen + 1);
2848 strncpy((char *)newCell->contents, token, tklen + 1);
2849 break;
2850 }
2851
2852 /* context exists make a symbol for it */
2853 newCell = getCell(CELL_SYMBOL);
2854 newCell->contents = (UINT)translateCreateSymbol(
2855 token, CELL_NIL, contextPtr, TRUE);
2856 break;
2857
2858 case TKN_QUOTE:
2859 newCell = getCell(CELL_QUOTE);
2860 linkCell(cell, newCell, listFlag);
2861 compileExpression(stream, newCell);
2862 break;
2863
2864 case TKN_LEFT_PAR:
2865 ++parStackCounter;
2866 newCell = getCell(CELL_EXPRESSION);
2867 linkCell(cell, newCell, listFlag);
2868 compileExpression(stream, newCell);
2869 break;
2870
2871 case TKN_RIGHT_PAR:
2872 if(parStackCounter == 0) errorMissingPar(stream);
2873 --parStackCounter;
2874 cell->next = nilCell;
2875 return(TRUE);
2876
2877 default:
2878 errorProcExt2(ERR_EXPRESSION, stuffString(lastPtr));
2879 return(0);
2880
2881 }
2882
2883 linkCell(cell, newCell, listFlag);
2884
2885 if(cell->type == CELL_QUOTE && listFlag == TRUE)
2886 return(TRUE);
2887
2888 listFlag = 0;
2889 cell = newCell;
2890
2891 if(parStackCounter != 0)
2892 {
2893 if(*(stream->ptr) != 0) goto GETNEXT;
2894 else errorMissingPar(stream);
2895 }
2896
2897 return(0);
2898 }
2899
2900
2901 void linkCell(CELL * left, CELL * right, int linkFlag)
2902 {
2903 if(linkFlag == 0)
2904 left->next = right;
2905 else left->contents = (UINT)right;
2906 }
2907
2908 int getToken(STREAM * stream, char * token, int * ptr_len)
2909 {
2910 char *tkn;
2911 char chr;
2912 int tknLen;
2913 int floatFlag;
2914 int bracketBalance;
2915 char buff[4];
2916
2917 tkn = token;
2918 tknLen = floatFlag = 0;
2919 *tkn = 0;
2920
2921 STRIP:
2922 if(stream->ptr > (stream->buffer + stream->size - 4 * MAX_STRING))
2923 {
2924 if(stream->handle == 0)
2925 {
2926 /* coming from commmand line or p_evalString */
2927 stream->buffer = stream->ptr;
2928 }
2929 else
2930 {
2931 stream->position += (stream->ptr - stream->buffer);
2932 lseek((int)stream->handle, stream->position, SEEK_SET);
2933 memset(stream->buffer, 0, stream->size + 1);
2934
2935 if(read(stream->handle, stream->buffer, stream->size) > 0)
2936
2937 stream->ptr = stream->buffer;
2938 else
2939 {
2940 *stream->ptr = 0;
2941 return(TKN_EMPTY);
2942 }
2943 }
2944 }
2945
2946 while((unsigned char)*stream->ptr <= ' ' && (unsigned char)*stream->ptr != 0)
2947 ++stream->ptr;
2948
2949 if(*stream->ptr == 0) return(TKN_EMPTY);
2950
2951 /* check for comments */
2952 if(*stream->ptr == ';' || *stream->ptr == '#')
2953 {
2954 stream->ptr++;
2955 for(;;)
2956 {
2957 if(*stream->ptr == 0) return(TKN_EMPTY);
2958 if(*stream->ptr == '\n' || *stream->ptr == '\r')
2959 break;
2960 stream->ptr++;
2961 }
2962 stream->ptr++;
2963 goto STRIP;
2964 }
2965
2966
2967 if( *stream->ptr == '-' || *stream->ptr == '+')
2968 {
2969 if(isDigit((unsigned char)*(stream->ptr + 1)) )
2970 *(tkn++) = *(stream->ptr++), tknLen++;
2971 }
2972
2973
2974 if(isDigit((unsigned char)*stream->ptr) ||
2975 (*stream->ptr == lc_decimal_point &&
2976 isDigit((unsigned char)*(stream->ptr + 1))))
2977 {
2978 if(*stream->ptr == '0' && isDigit((unsigned char)*(stream->ptr + 1)))
2979 {
2980 *(tkn++) = *(stream->ptr++), tknLen++;
2981 while(*stream->ptr < '8' && *stream->ptr >= '0' && *stream->ptr != 0)
2982 *(tkn++) = *(stream->ptr++), tknLen++;
2983 *tkn = 0;
2984 return(TKN_DECIMAL);
2985 }
2986
2987 while(isDigit((unsigned char)*stream->ptr) && tknLen < MAX_SYMBOL)
2988 *(tkn++) = *(stream->ptr++), tknLen++;
2989
2990 if(toupper(*stream->ptr) == 'X' && token[0] == '0')
2991 {
2992 *(tkn++) = *(stream->ptr++), tknLen++;
2993 while(isxdigit((unsigned char)*stream->ptr) && tknLen < MAX_SYMBOL)
2994 *(tkn++) = *(stream->ptr++), tknLen++;
2995 *tkn = 0;
2996 return(TKN_HEX);
2997 }
2998
2999 if(*stream->ptr == lc_decimal_point)
3000 {
3001 *(tkn++) = *(stream->ptr++), tknLen++;
3002 while(isDigit((unsigned char)*stream->ptr) && tknLen < MAX_SYMBOL)
3003 *(tkn++) = *(stream->ptr++), tknLen++;
3004 floatFlag = TRUE;
3005 }
3006 else if(toupper(*stream->ptr) != 'E')
3007 {
3008 *tkn = 0;
3009 return(TKN_DECIMAL);
3010 }
3011
3012 if(toupper(*stream->ptr) == 'E')
3013 {
3014 if(isDigit((unsigned char)*(stream->ptr+2))
3015 && ( *(stream->ptr+1) == '-' || *(stream->ptr+1) == '+') )
3016 *(tkn++) = *(stream->ptr++), tknLen++;
3017 if(isDigit((unsigned char)*(stream->ptr+1)))
3018 {
3019 *(tkn++) = *(stream->ptr++), tknLen++;
3020 while(isDigit((unsigned char)*stream->ptr) && tknLen < MAX_SYMBOL)
3021 *(tkn++) = *(stream->ptr++), tknLen++;
3022 }
3023 else
3024 {
3025 *tkn = 0;
3026 if(floatFlag == TRUE) return(TKN_FLOAT);
3027 else return(TKN_DECIMAL);
3028 }
3029 }
3030 *tkn = 0;
3031 return(TKN_FLOAT);
3032 }
3033 else
3034 {
3035 chr = *stream->ptr;
3036 *(tkn++) = *(stream->ptr++), tknLen++;
3037 switch(chr)
3038 {
3039 case '"':
3040 --tkn; --tknLen;
3041 while(*stream->ptr != '"' && *stream->ptr != 0
3042 && tknLen < MAX_STRING)
3043 {
3044 if(*stream->ptr == '\\')
3045 {
3046 stream->ptr++;
3047 if(isDigit((unsigned char)*stream->ptr) &&
3048 isDigit((unsigned char)*(stream->ptr+1)) &&
3049 isDigit((unsigned char)*(stream->ptr+2)))
3050 {
3051 memcpy(buff, stream->ptr, 3);
3052 buff[3] = 0;
3053 *(tkn++) = atoi(buff);
3054 tknLen++;
3055 stream->ptr += 3;
3056 continue;
3057 }
3058
3059 switch(*stream->ptr)
3060 {
3061 case 0:
3062 goto SRING_TO_LONG_ERROR;
3063 break;
3064 case 'n':
3065 *(tkn++) = '\n'; break;
3066 case '\\':
3067 *(tkn++) = '\\'; break;
3068 case 'r':
3069 *(tkn++) = '\r'; break;
3070 case 't':
3071 *(tkn++) = '\t'; break;
3072 case '"':
3073 *(tkn++) = '"'; break;
3074 case 'x':
3075 if(isxdigit((unsigned char)*(stream->ptr + 1)) &&
3076 isxdigit((unsigned char)*(stream->ptr + 2)))
3077 {
3078 buff[0] = '0';
3079 buff[1] = (unsigned char)*(stream->ptr + 1);
3080 buff[2] = (unsigned char)*(stream->ptr + 2);
3081 buff[3] = 0;
3082 *(tkn++) = strtol(buff, NULL, 16);
3083 stream->ptr += 2;
3084 break;
3085 }
3086 default:
3087 *(tkn++) = *stream->ptr;
3088 }
3089 stream->ptr++;
3090 tknLen++;
3091 }
3092 else *(tkn++) = *(stream->ptr++), tknLen++;
3093 }
3094 if(*stream->ptr == '\"')
3095 {
3096 *tkn = 0;
3097 stream->ptr++;
3098 *ptr_len = tknLen;
3099 return(TKN_STRING);
3100 }
3101 else
3102 {
3103 goto SRING_TO_LONG_ERROR;
3104 }
3105 break;
3106
3107 case '\'':
3108 case '(':
3109 case ')':
3110 *tkn = 0;
3111 return(chr);
3112 case '{':
3113 --tkn; --tknLen;
3114 bracketBalance = 1;
3115 while(*stream->ptr != 0 && tknLen < MAX_STRING)
3116 {
3117 if(*stream->ptr == '{') ++bracketBalance;
3118 if(*stream->ptr == '}') --bracketBalance;
3119 if(bracketBalance == 0) break;
3120 *(tkn++) = *(stream->ptr++), tknLen++;
3121 }
3122 if(*stream->ptr == '}')
3123 {
3124 *tkn = 0;
3125 stream->ptr++;
3126 *ptr_len = tknLen;
3127 return(TKN_STRING);
3128 }
3129 else
3130 {
3131 goto SRING_TO_LONG_ERROR;
3132 }
3133 break;
3134
3135
3136 case ',':
3137 case ':':
3138 *tkn = 0;
3139 return(TKN_SYMBOL);
3140
3141 case '[':
3142 while( tknLen < MAX_SYMBOL && *stream->ptr != 0 && *stream->ptr != ']')
3143 *(tkn++) = *(stream->ptr++), tknLen++;
3144 *tkn++ = ']';
3145 *tkn = 0;
3146 stream->ptr++;
3147
3148 return(TKN_SYMBOL);
3149
3150 default:
3151 while( tknLen < MAX_SYMBOL
3152 && (unsigned char)*stream->ptr > ' '
3153 && *stream->ptr != '"' && *stream->ptr != '\''
3154 && *stream->ptr != '(' && *stream->ptr != ')'
3155 && *stream->ptr != ':' && *stream->ptr != ','
3156 && *stream->ptr != 0)
3157 *(tkn++) = *(stream->ptr++), tknLen++;
3158 *tkn = 0;
3159 *ptr_len = tknLen;
3160 if(*stream->ptr == ':')
3161 {
3162 stream->ptr++;
3163 return(TKN_CONTEXT);
3164 }
3165 return(TKN_SYMBOL);
3166 }
3167 }
3168 *tkn=0;
3169 return(TKN_ERROR);
3170
3171 SRING_TO_LONG_ERROR:
3172 *tkn = 0;
3173 errorProcExt2(ERR_STRING_TOO_LONG,
3174 stuffStringN(token, strlen(token) < 40 ? strlen(token) : 40));
3175 return(TKN_ERROR);
3176 }
3177
3178 /* -------------------------- utilities ------------------------------------ */
3179
3180 size_t listlen(CELL * listHead)
3181 {
3182 size_t len = 0;
3183
3184 while(listHead != nilCell)
3185 {
3186 len++;
3187 listHead = listHead->next;
3188 }
3189
3190 return(len);
3191 }
3192
3193 /* -------------------------- functions to get parameters ------------------ */
3194
3195 void collectSymbols(SYMBOL * sPtr);
3196
3197 int getFlag(CELL * params)
3198 {
3199 params = evaluateExpression(params);
3200 return(!isNil(params));
3201 }
3202
3203 CELL * getInteger(CELL * params, UINT * number)
3204 {
3205 CELL * cell;
3206
3207 cell = evaluateExpression(params);
3208
3209 #ifndef NEWLISP64
3210 if(cell->type == CELL_INT64)
3211 {
3212 if(*(INT64 *)&cell->aux > 0xFFFFFFFF) *number = 0xFFFFFFFF;
3213 else if(*(INT64 *)&cell->aux < INT32_MIN_AS_INT64) *number = 0x80000000;
3214 else *number = *(INT64 *)&cell->aux;
3215 }
3216 else if(cell->type == CELL_LONG)
3217 *number = cell->contents;
3218 else if(cell->type == CELL_FLOAT)
3219 {
3220 #ifdef WIN_32
3221 if(isnan(*(double *)&cell->aux) || !_finite(*(double *)&cell->aux)) *number = 0;
3222 #else
3223 if(isnan(*(double *)&cell->aux)) *number = 0;
3224 #endif
3225 else if(*(double *)&cell->aux > 4294967295.0) *number = 0xFFFFFFFF;
3226 else if(*(double *)&cell->aux < -2147483648.0) *number = 0x80000000;
3227 else *number = *(double *)&cell->aux;
3228 }
3229 #else
3230 if(cell->type == CELL_LONG)
3231 *number = cell->contents;
3232 else if(cell->type == CELL_FLOAT)
3233 {
3234 if(isnan(*(double *)&cell->contents)) *number = 0;
3235 else if(*(double *)&cell->contents > 9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
3236 else if(*(double *)&cell->contents < -9223372036854775808.0) *number = 0x8000000000000000LL;
3237 else *number = *(double *)&cell->contents;
3238 }
3239 #endif
3240 else
3241 {
3242 *number = 0;
3243 return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
3244 }
3245
3246 return(params->next);
3247 }
3248
3249 #ifndef NEWLISP64
3250 CELL * getInteger64(CELL * params, INT64 * number)
3251 {
3252 CELL * cell;
3253
3254 cell = evaluateExpression(params);
3255
3256 if(cell->type == CELL_INT64)
3257 *number = *(INT64 *)&cell->aux;
3258 else if(cell->type == CELL_LONG)
3259 *number = (int)cell->contents;
3260 else if(cell->type == CELL_FLOAT)
3261 {
3262 #ifdef WIN_32
3263 if(isnan(*(double *)&cell->aux) || !_finite(*(double *)&cell->aux)) *number = 0;
3264 #else
3265 if(isnan(*(double *)&cell->aux)) *number = 0;
3266 #endif
3267 else if(*(double *)&cell->aux > 9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
3268 else if(*(double *)&cell->aux < -9223372036854775808.0) *number = 0x8000000000000000LL;
3269 else *number = *(double *)&cell->aux;
3270 }
3271 else
3272 {
3273 *number = 0;
3274 return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
3275 }
3276
3277 return(params->next);
3278 }
3279
3280 #else
3281 CELL * getInteger64(CELL * params, INT64 * number)
3282 {
3283 CELL * cell;
3284
3285 cell = evaluateExpression(params);
3286
3287 if(cell->type == CELL_LONG)
3288 *number = cell->contents;
3289 else if(cell->type == CELL_FLOAT)
3290 {
3291 if(isnan(*(double *)&cell->contents)) *number = 0;
3292 else if(*(double *)&cell->contents > 9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
3293 else if(*(double *)&cell->contents < -9223372036854775808.0) *number = 0x8000000000000000LL;
3294 else *number = *(double *)&cell->contents;
3295 }
3296 else
3297 {
3298 *number = 0;
3299 return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
3300 }
3301
3302 return(params->next);
3303 }
3304 #endif
3305
3306 CELL * getIntegerExt(CELL * params, UINT * number, int evalFlag)
3307 {
3308 CELL * cell;
3309
3310 if(evalFlag)
3311 cell = evaluateExpression(params);
3312 else cell = params;
3313
3314 #ifndef NEWLISP64
3315 if(cell->type == CELL_INT64)
3316 {
3317 if(*(INT64 *)&cell->aux > 0xFFFFFFFF) *number = 0xFFFFFFFF;
3318 else if(*(INT64 *)&cell->aux < INT32_MIN_AS_INT64) *number = 0x80000000;
3319 else *number = *(INT64 *)&cell->aux;
3320 }
3321 else if(cell->type == CELL_LONG)
3322 *number = cell->contents;
3323 else if(cell->type == CELL_FLOAT)
3324 {
3325 #ifdef WIN_32
3326 if(isnan(*(double *)&cell->aux) || !_finite(*(double *)&cell->aux)) *number = 0;
3327 #else
3328 if(isnan(*(double *)&cell->aux)) *number = 0;
3329 #endif
3330 else if(*(double *)&cell->aux > 4294967295.0) *number = 0xFFFFFFFF;
3331 else if(*(double *)&cell->aux < -2147483648.0) *number = 0x80000000;
3332 else *number = *(double *)&cell->aux;
3333 }
3334 #else
3335 if(cell->type == CELL_LONG)
3336 *number = cell->contents;
3337 else if(cell->type == CELL_FLOAT)
3338 {
3339 if(isnan(*(double *)&cell->contents)) *number = 0;
3340 else if(*(double *)&cell->contents > 9223372036854775807.0) *number = 0x7FFFFFFFFFFFFFFFLL;
3341 else if(*(double *)&cell->contents < -9223372036854775808.0) *number = 0x8000000000000000LL;
3342 else *number = *(double *)&cell->contents;
3343 }
3344 #endif
3345 else
3346 {
3347 *number = 0;
3348 return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
3349 }
3350
3351 return(params->next);
3352 }
3353
3354
3355 CELL * getFloat(CELL * params, double * floatNumber)
3356 {
3357 CELL * cell;
3358
3359 cell = evaluateExpression(params);
3360
3361 #ifndef NEWLISP64
3362 if(cell->type == CELL_FLOAT)
3363 *floatNumber = *(double *)&cell->aux;
3364 else if(cell->type == CELL_INT64)
3365 *floatNumber = *(INT64 *)&cell->aux;
3366 #else
3367 if(cell->type == CELL_FLOAT)
3368 *floatNumber = *(double *)&cell->contents;
3369 #endif
3370 else if(cell->type == CELL_LONG)
3371 *floatNumber = (long)cell->contents;
3372 else
3373 {
3374 *floatNumber = 0.0;
3375 return(errorProcArgs(ERR_NUMBER_EXPECTED, params));
3376 }
3377
3378 return(params->next);
3379 }
3380
3381
3382 CELL * getString(CELL * params, char * * stringPtr)
3383 {
3384 CELL * cell;
3385
3386 cell = evaluateExpression(params);
3387
3388 if(cell->type != CELL_STRING)
3389 {
3390 *stringPtr = "";
3391 return(errorProcArgs(ERR_STRING_EXPECTED, params));
3392 }
3393 *stringPtr = (char *)cell->contents;
3394 return(params->next);
3395 }
3396
3397
3398 CELL * getStringSize(CELL * params, char * * stringPtr, size_t * size, int evalFlag)
3399 {
3400 CELL * cell;
3401
3402 if(params == nilCell)
3403 return(errorProc(ERR_MISSING_ARGUMENT));
3404
3405 if(evalFlag)
3406 cell = evaluateExpression(params);
3407 else cell = params;
3408
3409 if(cell->type != CELL_STRING)
3410 {
3411 *stringPtr = "";
3412 return(errorProcArgs(ERR_STRING_EXPECTED, params));
3413 }
3414
3415 *stringPtr = (char *)cell->contents;
3416 if(size) *size = cell->aux - 1;
3417 return(params->next);
3418 }
3419
3420
3421 CELL * getSymbol(CELL * params, SYMBOL * * symbol)
3422 {
3423 CELL * cell;
3424
3425 cell = evaluateExpression(params);
3426
3427 if(cell->type != CELL_SYMBOL)
3428 {
3429 if(cell->type == CELL_DYN_SYMBOL)
3430 {
3431 *symbol = getDynamicSymbol(cell);
3432 return(params->next);
3433 }
3434 *symbol = nilSymbol;
3435 return(errorProcArgs(ERR_SYMBOL_EXPECTED, params));
3436 }
3437
3438 *symbol = (SYMBOL *)cell->contents;
3439 return(params->next);
3440 }
3441
3442 /* only used for internal syms: $timer, $error-event and $signal-1-> $signal-32 */
3443 CELL * getCreateSymbol(CELL * params, SYMBOL * * symbol, char * name)
3444 {
3445 CELL * cell;
3446
3447 cell = evaluateExpression(params);
3448
3449 if(cell->type != CELL_SYMBOL)
3450 {
3451 if(cell->type == CELL_DYN_SYMBOL)
3452 {
3453 *symbol = getDynamicSymbol(cell);
3454 return(params->next);
3455 }
3456 *symbol = translateCreateSymbol(name, CELL_NIL, mainContext, TRUE);
3457 (*symbol)->flags |= SYMBOL_PROTECTED | SYMBOL_GLOBAL;
3458 (*symbol)->contents = (UINT)copyCell(cell);
3459 }
3460 else
3461 *symbol = (SYMBOL *)cell->contents;
3462
3463 return(params->next);
3464 }
3465
3466
3467 CELL * getContext(CELL * params, SYMBOL * * context)
3468 {
3469 CELL * cell;
3470
3471 cell = evaluateExpression(params);
3472
3473 if(cell->type == CELL_CONTEXT || cell->type == CELL_SYMBOL)
3474 *context = (SYMBOL *)cell->contents;
3475 else
3476 {
3477 *context = NULL;
3478 return(errorProcArgs(ERR_CONTEXT_EXPECTED, params));
3479 }
3480
3481 if(symbolType(*context) != CELL_CONTEXT)
3482 return(errorProcExt(ERR_CONTEXT_EXPECTED, params));
3483
3484 return(params->next);
3485 }
3486
3487
3488 /* gets the first element, without list envelope */
3489 CELL * getListHead(CELL * params, CELL * * list)
3490 {
3491 CELL * cell;
3492
3493 cell = evaluateExpression(params);
3494
3495 if(!isList(cell->type))
3496 {
3497 *list = copyCell(nilCell);
3498 return(errorProcArgs(ERR_LIST_EXPECTED, params));
3499 }
3500 *list = (CELL *)cell->contents;
3501 return(params->next);
3502 }
3503
3504 /* gets a list from an expression or default functor
3505 inside the (L foo) parameter form in nth and ref functions
3506 returns the params ptr for foo */
3507 CELL * getList(CELL * params, CELL * * result, int setFlag)
3508 {
3509 SYMBOL * sPtr;
3510 CELL * list;
3511
3512 list = (CELL *)params->contents;
3513 params = list->next;
3514 if(isSymbol(list->type))
3515 {
3516 if(list->type == CELL_SYMBOL)
3517 sPtr = (SYMBOL *)list->contents;
3518 else
3519 sPtr = getDynamicSymbol(list);
3520
3521 list = (CELL *)sPtr->contents;
3522
3523 if(list->type == CELL_CONTEXT)
3524 {
3525 sPtr = (translateCreateSymbol(
3526 ((SYMBOL*)list->contents)->name,
3527 CELL_NIL,
3528 (SYMBOL*)list->contents,
3529 TRUE));
3530 list = (CELL *)sPtr->contents;
3531 }
3532
3533 if(isProtected(sPtr->flags) && setFlag)
3534 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(sPtr)));
3535 }
3536 else
3537 {
3538 if(setFlag)
3539 list = evalCheckProtected(list, NULL);
3540 else
3541 list = evaluateExpression(list);
3542
3543 if(list->type == CELL_CONTEXT)
3544 {
3545 sPtr = (translateCreateSymbol(
3546 ((SYMBOL*)list->contents)->name,
3547 CELL_NIL,
3548 (SYMBOL*)list->contents,
3549 TRUE));
3550
3551 if(setFlag && isProtected(sPtr->flags))
3552 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(sPtr)));
3553
3554 list = (CELL *)sPtr->contents;
3555 }
3556 }
3557
3558 *result = list;
3559
3560 return(params);
3561 }
3562
3563 /* ------------------------------- core predicates ------------------------ */
3564
3565 CELL * p_setlocale(CELL * params)
3566 {
3567 struct lconv * lc;
3568 char * locale;
3569 UINT category;
3570
3571 if(params != nilCell)
3572 params = getString(params, &locale);
3573 else locale = NULL;
3574
3575 if(params != nilCell)
3576 getInteger(params, &category);
3577 else category = LC_ALL;
3578
3579 locale = setlocale(category, locale);
3580
3581 if(locale == NULL)
3582 return(nilCell);
3583
3584 stringOutputRaw = (strcmp(locale, "C") == 0);
3585
3586 lc = localeconv();
3587 lc_decimal_point = *lc->decimal_point;
3588
3589 return(stuffString(locale));
3590 }
3591
3592
3593 CELL * p_commandLine(CELL * params)
3594 {
3595 commandLineFlag = getFlag(params);
3596 return((commandLineFlag == FALSE ? nilCell : trueCell));
3597 }
3598
3599
3600 CELL * p_quote(CELL * params)
3601 {
3602 return(copyCell(params));
3603 }
3604
3605
3606 CELL * p_eval(CELL * params)
3607 {
3608 if(params->type == CELL_SYMBOL)
3609 params = (CELL*)((SYMBOL *)params->contents)->contents;
3610 else
3611 params = evaluateExpression(params);
3612
3613 if(params->type == CELL_SYMBOL)
3614 {
3615 if(symbolProtectionLevel && symbolProtectionLevel == (recursionCount - 1))
3616 {
3617 if(isProtected(((SYMBOL *)params->contents)->flags))
3618 symbolProtectionLevel = 0xFFFFFFFF;
3619 }
3620 /* eval returns original symbol contents for usage in macros */
3621 pushResultFlag = 0;
3622 return((CELL*)((SYMBOL *)params->contents)->contents);
3623 }
3624
3625 return(copyCell(evaluateExpression(params)));
3626 }
3627
3628
3629 CELL * p_catch(CELL * params)
3630 {
3631 jmp_buf errorJumpSave;
3632 int envStackIdxSave;
3633 int lambdaStackIdxSave;
3634 int recursionCountSave;
3635 int value;
3636 CELL * expr;
3637 CELL * result;
3638 SYMBOL * symbol = NULL;
3639 SYMBOL * contextSave;
3640
3641 expr = params;
3642 if(params->next != nilCell)
3643 {
3644 getSymbol(params->next, &symbol);
3645 if(isProtected(symbol->flags))
3646 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
3647 }
3648
3649 memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
3650 envStackIdxSave = envStackIdx;
3651 recursionCountSave = recursionCount;
3652 lambdaStackIdxSave = lambdaStackIdx;
3653 contextSave = currentContext;
3654
3655 if((value = setjmp(errorJump)) != 0)
3656 {
3657 memcpy(errorJump, errorJumpSave, (sizeof(jmp_buf)));
3658 recoverEnvironment(envStackIdxSave);
3659 recursionCount = recursionCountSave;
3660 lambdaStackIdx = lambdaStackIdxSave;
3661 currentContext = contextSave;
3662 evalCatchFlag--;
3663
3664 if(value == EXCEPTION_THROW)
3665 {
3666 if(symbol == NULL) return(throwResult);
3667 deleteList((CELL*)symbol->contents);
3668 symbol->contents = (UINT)throwResult;
3669 return(trueCell);
3670 }
3671
3672 if(errorStream.buffer != NULL)
3673 {
3674 if(symbol == NULL)
3675 {
3676 if(errorEvent == nilSymbol && evalCatchFlag == 0)
3677 varPrintf(OUT_CONSOLE, "\n%.1024s\n", errorStream.buffer);
3678 longjmp(errorJump, value);
3679 }
3680 deleteList((CELL*)symbol->contents);
3681 symbol->contents = (UINT)stuffString(errorStream.buffer);
3682 }
3683
3684 return(nilCell);
3685 }
3686
3687 evalCatchFlag++;
3688 result = copyCell(evaluateExpression(expr));
3689 evalCatchFlag--;
3690 memcpy(errorJump, errorJumpSave, sizeof(jmp_buf));
3691
3692 if(symbol == NULL) return(result);
3693
3694 deleteList((CELL*)symbol->contents);
3695 symbol->contents = (UINT)result;
3696
3697 return(trueCell);
3698 }
3699
3700
3701 CELL * p_throw(CELL * params)
3702 {
3703 if(evalCatchFlag == 0)
3704 return(errorProc(ERR_THROW_WO_CATCH));
3705
3706 throwResult = copyCell(evaluateExpression(params));
3707 longjmp(errorJump, EXCEPTION_THROW);
3708
3709 return(trueCell);
3710 }
3711
3712 CELL * p_throwError(CELL * params)
3713 {
3714 evalFunc = NULL;
3715 errorProcExt(ERR_USER_ERROR, evaluateExpression(params));
3716 return(nilCell);
3717 }
3718
3719
3720 CELL * p_evalString(CELL * params)
3721 {
3722 SYMBOL * context = currentContext;
3723 char * evalString;
3724
3725 params = getString(params, &evalString);
3726 if(params->next != nilCell)
3727 {
3728 if((context = getCreateContext(params->next, TRUE)) == NULL)
3729 return(errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, params->next));
3730 }
3731
3732 return(copyCell(sysEvalString(evalString, params, context)));
3733 }
3734
3735 CELL * sysEvalString(char * evalString, CELL * proc, SYMBOL * context)
3736 {
3737 CELL * program;
3738 STREAM stream;
3739 CELL * resultCell = nilCell;
3740 jmp_buf errorJumpSave;
3741 int recursionCountSave;
3742 int envStackIdxSave;
3743 int resultIdxSave;
3744 SYMBOL * contextSave = NULL;
3745
3746 makeStreamFromString(&stream, evalString);
3747 recursionCountSave = recursionCount;
3748 envStackIdxSave = envStackIdx;
3749 resultIdxSave = resultStackIdx;
3750 contextSave = currentContext;
3751 currentContext = context;
3752
3753 if(proc != nilCell)
3754 {
3755 evalCatchFlag++;
3756 memcpy(errorJumpSave, errorJump, sizeof(jmp_buf));
3757
3758 if(setjmp(errorJump) != 0)
3759 {
3760 memcpy(errorJump, errorJumpSave, (sizeof(jmp_buf)));
3761 recoverEnvironment(envStackIdxSave);
3762 evalCatchFlag--;
3763 recursionCount = recursionCountSave;
3764 currentContext = contextSave;
3765 return(evaluateExpression(proc));
3766 }
3767 }
3768
3769 while(TRUE)
3770 {
3771 pushResult(program = getCell(CELL_QUOTE));
3772 if(compileExpression(&stream, program) == 0) break;
3773 resultCell = evaluateExpression((CELL *)program->contents);
3774 if(resultStackIdx > (MAX_RESULT_STACK - 256))
3775 {
3776 program = popResult();
3777 cleanupResults(resultIdxSave);
3778 pushResult(program);
3779 }
3780 }
3781
3782 if(proc != nilCell)
3783 {
3784 memcpy(errorJump, errorJumpSave, (sizeof(jmp_buf)));
3785 evalCatchFlag--;
3786 }
3787
3788 currentContext = contextSave;
3789 return(resultCell);
3790 }
3791
3792 CELL * p_curry(CELL * params)
3793 {
3794 CELL * lambda;
3795 CELL * cell;
3796 SYMBOL * xPtr;
3797
3798 xPtr = translateCreateSymbol("_x", CELL_NIL, currentContext, TRUE);
3799 lambda = getCell(CELL_LAMBDA);
3800 cell = getCell(CELL_EXPRESSION);
3801 lambda->contents = (UINT)cell;
3802 cell->contents = (UINT)stuffSymbol(xPtr);
3803 cell->next = getCell(CELL_EXPRESSION);
3804 cell = cell->next;
3805 cell->contents = (UINT)copyCell(params);
3806 cell = (CELL *)cell->contents;
3807 cell->next = copyCell(params->next);
3808 cell = cell->next;
3809 cell->next = stuffSymbol(xPtr);
3810
3811 return(lambda);
3812 }
3813
3814
3815 CELL * p_apply(CELL * params)
3816 {
3817 CELL * expr;
3818 CELL * args;
3819 CELL * cell;
3820 CELL * result;
3821 CELL * func;
3822 ssize_t count, cnt;
3823 int resultIdxSave;
3824
3825 func = evaluateExpression(params);
3826
3827 cell = copyCell(func);
3828 expr = getCell(CELL_EXPRESSION);
3829 expr->contents = (UINT)cell;
3830
3831 params = params->next;
3832 args = evaluateExpression(params);
3833
3834 if(params->next != nilCell)
3835 getInteger(params->next, (UINT *)&count);
3836 else count = -1;
3837 if(count < 2) count = MAX_LONG;
3838
3839 resultIdxSave = resultStackIdx + 2;
3840
3841 if(args->type == CELL_EXPRESSION)
3842 {
3843 args = (CELL *)args->contents;
3844 cnt = count;
3845 REDUCE:
3846 while(args != nilCell && cnt-- > 0)
3847 {
3848 if(isSelfEval(args->type))
3849 {
3850 cell->next = copyCell(args);
3851 cell = cell->next;
3852 }
3853 else
3854 {
3855 cell->next = getCell(CELL_QUOTE);
3856 cell = cell->next;
3857 cell->contents = (UINT)copyCell(args);
3858 }
3859 args = args->next;
3860 }
3861 pushResult(expr);
3862 result = copyCell(evaluateExpression(expr));
3863 if(args == nilCell) return(result);
3864 cell = copyCell(func);
3865 expr = getCell(CELL_EXPRESSION);
3866 expr->contents = (UINT)cell;
3867 cell->next = getCell(CELL_QUOTE);
3868 cell = cell->next;
3869 cell->contents = (UINT)result;
3870 cnt = count - 1;
3871 cleanupResults(resultIdxSave);
3872 goto REDUCE;
3873 }
3874
3875 pushResult(expr);
3876 return(copyCell(evaluateExpression(expr)));
3877 }
3878
3879
3880 CELL * p_args(CELL * params)
3881 {
3882 if(params != nilCell)
3883 return(copyCell(implicitIndexList((CELL*)argsSymbol->contents, params)));
3884 return(copyCell((CELL*)argsSymbol->contents));
3885 }
3886
3887 /* in-place expansion, if symbol==NULL all uppercase, nil vars are expanded */
3888 CELL * expand(CELL * expr, SYMBOL * symbol)
3889 {
3890 CELL * cell = nilCell;
3891 SYMBOL * sPtr;
3892 int enable = 1;
3893 CELL * cont, * rep;
3894 int wchar;
3895
3896 if(expr->type == CELL_SYMBOL)
3897 return(expr);
3898 /*
3899 return(copyCell(expr));
3900 */
3901
3902 if(isEnvelope(expr->type))
3903 cell = (CELL*)expr->contents;
3904
3905 while(cell != nilCell)
3906 {
3907 if(cell->type == CELL_SYMBOL && (cell->contents == (UINT)symbol || symbol == NULL) )
3908 {
3909 sPtr = (SYMBOL *)cell->contents;
3910 if(symbol == NULL)
3911 {
3912 #ifndef SUPPORT_UTF8
3913 wchar = *sPtr->name;
3914 #else
3915 utf8_wchar(sPtr->name, &wchar);
3916 #endif
3917 enable = (wchar > 64 && wchar < 91);
3918 cont = (CELL*)sPtr->contents;
3919 enable = (enable && cont->contents != (UINT)nilCell
3920 && cont->contents != (UINT)nilSymbol);
3921 }
3922
3923 if(symbol || enable)
3924 {
3925 rep = copyCell((CELL*)sPtr->contents);
3926 cell->type = rep->type;
3927 cell->aux = rep->aux;
3928 cell->contents = rep->contents;
3929 rep->type = CELL_LONG;
3930 rep->aux = 0;
3931 rep->contents = 0;
3932 deleteList(rep);
3933 }
3934 }
3935
3936 else if(isEnvelope(cell->type)) expand(cell, symbol);
3937 cell = cell->next;
3938 }
3939
3940 return(expr);
3941 }
3942
3943 CELL * blockExpand(CELL * block, SYMBOL * symbol)
3944 {
3945 CELL * expanded = nilCell;
3946 CELL * next = nilCell;
3947
3948 while(block != nilCell)
3949 {
3950 if(expanded == nilCell)
3951 {
3952 next = expand(copyCell(block), symbol);
3953 expanded = next;
3954 }
3955 else
3956 {
3957 next->next = expand(copyCell(block), symbol);
3958 next = next->next;
3959 }
3960 block = block->next;
3961 }
3962
3963 return(expanded);
3964 }
3965
3966
3967 CELL * p_expand(CELL * params)
3968 {
3969 SYMBOL * symbol;
3970 CELL * expr;
3971 CELL * next;
3972 CELL * list;
3973 CELL * cell;
3974
3975 expr = evaluateExpression(params);
3976 if(!isList(expr->type) && expr->type != CELL_QUOTE)
3977 return(errorProcExt(ERR_LIST_EXPECTED, expr));
3978
3979 params = next = params->next;
3980 if(params == nilCell)
3981 return(expand(copyCell(expr), NULL));
3982
3983 while((params = next) != nilCell)
3984 {
3985 next = params->next;
3986 params = evaluateExpression(params);
3987 if(params->type == CELL_SYMBOL)
3988 symbol = (SYMBOL*)params->contents;
3989 else if(params->type == CELL_DYN_SYMBOL)
3990 symbol = getDynamicSymbol(params);
3991 else if(params->type == CELL_EXPRESSION)
3992 {
3993 list = (CELL*)params->contents;
3994 while(list != nilCell)
3995 {
3996 if(list->type != CELL_EXPRESSION)
3997 return(errorProcExt(ERR_LIST_EXPECTED, list));
3998 cell = (CELL *)list->contents;
3999 if(cell->type != CELL_SYMBOL)
4000 return(errorProcExt(ERR_SYMBOL_EXPECTED, cell));
4001 symbol = (SYMBOL*)cell->contents;
4002 pushEnvironment(symbol->contents);
4003 pushEnvironment(symbol);
4004 symbol->contents = (UINT)cell->next;
4005 expr = expand(copyCell(expr), symbol);
4006 symbol = (SYMBOL*)popEnvironment();
4007 symbol->contents = popEnvironment();
4008 pushResult(expr);
4009 list = list->next;
4010 continue;
4011 }
4012 break;
4013 }
4014 else
4015 return(errorProcExt(ERR_LIST_OR_SYMBOL_EXPECTED, params));
4016 expr = expand(copyCell(expr), symbol);
4017 pushResult(expr);
4018 }
4019
4020 return(copyCell(expr));
4021 }
4022
4023
4024 CELL * defineOrMacro(CELL * params, UINT cellType)
4025 {
4026 SYMBOL * symbol;
4027 CELL * argsPtr;
4028 CELL * args;
4029 CELL * lambda;
4030
4031 if(params->type != CELL_EXPRESSION)
4032 return(errorProcExt(ERR_LIST_OR_SYMBOL_EXPECTED, params));
4033
4034 /* symbol to be defined */
4035 argsPtr = (CELL *)params->contents;
4036 if(argsPtr->type != CELL_SYMBOL)
4037 {
4038 if(argsPtr->type == CELL_DYN_SYMBOL)
4039 symbol = getDynamicSymbol(argsPtr);
4040 else
4041 return(errorProcExt(ERR_SYMBOL_EXPECTED, params));
4042 }
4043 else symbol = (SYMBOL *)argsPtr->contents;
4044
4045 if(isProtected(symbol->flags))
4046 return(errorProcExt(ERR_SYMBOL_PROTECTED, params));
4047
4048 /* local symbols */
4049 argsPtr = copyList(argsPtr->next);
4050 lambda = getCell(cellType);
4051 lambda->aux = (UINT)nilCell;
4052 args = getCell(CELL_EXPRESSION);
4053 args->contents = (UINT)argsPtr;
4054 /* body expressions */
4055 args->next = copyList(params->next);
4056 lambda->contents = (UINT)args;
4057
4058 deleteList((CELL *)symbol->contents);
4059
4060 symbol->contents = (UINT)lambda;
4061
4062 pushResultFlag = FALSE;
4063 return(lambda);
4064 }
4065
4066 #define TYPE_SET 1
4067 #define TYPE_CONSTANT 2
4068 #define TYPE_DEFINE 3
4069
4070 CELL * p_define(CELL * params)
4071 {
4072 if(params->type != CELL_SYMBOL)
4073 {
4074 if(params->type != CELL_DYN_SYMBOL)
4075 return(defineOrMacro(params, CELL_LAMBDA));
4076 return(setDefine(getDynamicSymbol(params), params->next, TYPE_SET));
4077 }
4078
4079 return(setDefine((SYMBOL *)params->contents, params->next, TYPE_SET));
4080 }
4081
4082
4083 CELL * p_defineMacro(CELL * params)
4084 {
4085 return(defineOrMacro(params, CELL_MACRO));
4086 }
4087
4088
4089 CELL * p_setq(CELL * params)
4090 {
4091 SYMBOL * symbol;
4092 CELL * next;
4093
4094 for(;;)
4095 {
4096 if(params->type != CELL_SYMBOL)
4097 {
4098 if(params->type == CELL_DYN_SYMBOL)
4099 symbol = getDynamicSymbol(params);
4100 else
4101 return(errorProcExt(ERR_SYMBOL_EXPECTED, params));
4102 }
4103 else
4104 symbol = (SYMBOL *)params->contents;
4105 params = params->next;
4106 next = params->next;
4107 if(params == nilCell)
4108 return(copyCell((CELL*)symbol->contents));
4109 if(next == nilCell) return(setDefine(symbol, params, TYPE_SET));
4110 setDefine(symbol, params, TYPE_SET);
4111 params = next;
4112 }
4113 }
4114
4115
4116 CELL * p_set(CELL *params)
4117 {
4118 SYMBOL * symbol;
4119 CELL * next;
4120
4121 for(;;)
4122 {
4123 params = getSymbol(params, &symbol);
4124 next = params->next;
4125 if(params == nilCell)
4126 return(copyCell((CELL*)symbol->contents));
4127 if(next == nilCell) return(setDefine(symbol, params, TYPE_SET));
4128 setDefine(symbol, params, TYPE_SET);
4129 pushResultFlag = TRUE;
4130 params = next;
4131 }
4132 }
4133
4134
4135 CELL * p_constant(CELL *params)
4136 {
4137 SYMBOL * symbol;
4138 CELL * next;
4139
4140 for(;;)
4141 {
4142 params = getSymbol(params, &symbol);
4143 /* protect contexts from being set, but not vars holding contexts */
4144 if(symbolType(symbol) == CELL_CONTEXT && (SYMBOL *)((CELL *)symbol->contents)->contents == symbol)
4145 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
4146 next = params->next;
4147 if(symbol->context != currentContext)
4148 return(errorProcExt2(ERR_NOT_CURRENT_CONTEXT, stuffSymbol(symbol)));
4149 symbol->flags |= SYMBOL_PROTECTED;
4150 if(params == nilCell)
4151 return(copyCell((CELL*)symbol->contents));
4152 if(next == nilCell) return(setDefine(symbol, params, TYPE_CONSTANT));
4153 setDefine(symbol, params, TYPE_CONSTANT);
4154 params = next;
4155 }
4156 }
4157
4158
4159 CELL * setDefine(SYMBOL * symbol, CELL * params, int type)
4160 {
4161 CELL * cell;
4162
4163 if(isProtected(symbol->flags))
4164 {
4165 if(type == TYPE_CONSTANT)
4166 {
4167 if(symbol == nilSymbol || symbol == trueSymbol)
4168 return(errorProcExt2(ERR_SYMBOL_EXPECTED, stuffSymbol(symbol)));
4169 }
4170 else
4171 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
4172 }
4173
4174 cell = copyCell(evaluateExpression(params));
4175
4176 deleteList((CELL *)symbol->contents);
4177 symbol->contents = (UINT)(cell);
4178
4179 pushResultFlag = FALSE;
4180 return(cell);
4181 }
4182
4183
4184 CELL * p_global(CELL * params)
4185 {
4186 SYMBOL * sPtr;
4187
4188 do
4189 {
4190 params = getSymbol(params, &sPtr);
4191 if(sPtr->context != mainContext || currentContext != mainContext)
4192 return(errorProcExt2(ERR_NOT_IN_MAIN, stuffSymbol(sPtr)));
4193 else
4194 sPtr->flags |= SYMBOL_GLOBAL;
4195 } while (params != nilCell);
4196
4197 return(stuffSymbol(sPtr));
4198 }
4199
4200 #define LET_STD 0
4201 #define LET_NEST 1
4202 #define LET_EXPAND 2
4203 #define LET_LOCAL 3
4204
4205 CELL * let(CELL * params, int type);
4206
4207 CELL * p_let(CELL * params) { return(let(params, LET_STD)); }
4208 CELL * p_letn(CELL * params) { return(let(params, LET_NEST)); }
4209 CELL * p_letExpand(CELL * params) { return(let(params, LET_EXPAND)); }
4210 CELL * p_local(CELL * params) { return(let(params, LET_LOCAL)); }
4211
4212 CELL * let(CELL * params, int type)
4213 {
4214 CELL * inits;
4215 CELL * cell;
4216 CELL * result = nilCell;
4217 CELL * args = NULL, * list = NULL;
4218 CELL * body;
4219 SYMBOL * symbol;
4220 int localCount = 0;
4221
4222 if(params->type != CELL_EXPRESSION)
4223 return(errorProcExt(ERR_INVALID_LET, params));
4224
4225 /* evaluate symbol assignments in parameter list
4226 handle double syntax classic: (let ((v1 e1) (v2 e2) ...) ...)
4227 and: (let (v1 e1 v2 e2 ...) ...)
4228 */
4229 inits = (CELL*)params->contents;
4230 body = params->next;
4231
4232 if(type == LET_LOCAL)
4233 {
4234 while(inits != nilCell)
4235 {
4236 if(inits->type != CELL_SYMBOL)
4237 return(errorProcExt(ERR_SYMBOL_EXPECTED, inits));
4238 symbol = (SYMBOL *)inits->contents;
4239 if(isProtected(symbol->flags))
4240 return(errorProcExt(ERR_SYMBOL_PROTECTED, inits));
4241 pushEnvironment(symbol->contents);
4242 pushEnvironment(symbol);
4243 symbol->contents = (UINT)nilCell;
4244 localCount++;
4245 inits = inits->next;
4246 }
4247 goto EVAL_LET_BODY;
4248 }
4249
4250 while(inits != nilCell)
4251 {
4252 if(inits->type != CELL_EXPRESSION)
4253 {
4254 if(inits->type != CELL_SYMBOL)
4255 return(errorProcExt(ERR_INVALID_LET, inits));
4256 cell = inits;
4257 inits = ((CELL*)cell->next)->next;
4258 }
4259 else
4260 {
4261 cell = (CELL *)inits->contents;
4262 if(cell->type != CELL_SYMBOL)
4263 return(errorProcExt(ERR_SYMBOL_EXPECTED, inits));
4264 inits = inits->next;
4265 }
4266
4267 if(type == LET_STD || type == LET_EXPAND)
4268 {
4269 if(localCount == 0)
4270 list = args = copyCell(evaluateExpression(cell->next));
4271 else
4272 {
4273 args->next = copyCell(evaluateExpression(cell->next));
4274 args = args->next;
4275 }
4276 }
4277 else /* LET_NEST */
4278 {
4279 symbol = (SYMBOL *)cell->contents;
4280 if(isProtected(symbol->flags))
4281 return(errorProcExt(ERR_SYMBOL_PROTECTED, cell));
4282 args = copyCell(evaluateExpression(cell->next));
4283 pushEnvironment((CELL *)symbol->contents);
4284 pushEnvironment((UINT)symbol);
4285 symbol->contents = (UINT)args;
4286 }
4287
4288 localCount++;
4289 }
4290
4291 /* save symbols and get new bindings */
4292 if(type == LET_STD || type == LET_EXPAND)
4293 {
4294 inits = (CELL*)params->contents;
4295 while(inits != nilCell)
4296 {
4297 if(inits->type == CELL_EXPRESSION)
4298 {
4299 cell = (CELL *)inits->contents;
4300 inits = inits->next;
4301 }
4302 else
4303 {
4304 cell = inits;
4305 inits = ((CELL*)cell->next)->next;
4306 }
4307
4308 symbol = (SYMBOL *)cell->contents;
4309
4310 if(isProtected(symbol->flags))
4311 return(errorProcExt(ERR_SYMBOL_PROTECTED, cell));
4312
4313 pushEnvironment((CELL *)symbol->contents);
4314 pushEnvironment((UINT)symbol);
4315 symbol->contents = (UINT)list;
4316
4317 args = list;
4318 list = list->next;
4319 args->next = nilCell; /* decouple */
4320
4321 /* hook in LET_EXPAND mode here */
4322 if(type == LET_EXPAND)
4323 {
4324 body = blockExpand(body, symbol);
4325 pushResult(body);
4326 }
4327
4328 }
4329 }
4330
4331 EVAL_LET_BODY:
4332 /* evaluate body expressions */
4333 while(body != nilCell)
4334 {
4335 if(result != nilCell) deleteList(result);
4336 result = copyCell(evaluateExpression(body));
4337 body = body->next;
4338 }
4339
4340 /* restore environment */
4341 while(localCount--)
4342 {
4343 symbol = (SYMBOL *)popEnvironment();
4344 if(isProtected(symbol->flags) && (symbol != argsSymbol))
4345 symbol->flags &= ~SYMBOL_PROTECTED;
4346 deleteList((CELL *)symbol->contents);
4347 symbol->contents = popEnvironment();
4348 }
4349
4350 return(result);
4351 }
4352
4353 CELL * p_first(CELL * params)
4354 {
4355 char str[2];
4356 CELL * cell;
4357
4358 cell = evaluateExpression(params);
4359
4360 if(cell->type == CELL_STRING)
4361 {
4362 if((str[0] = *(char *)cell->contents) == 0)
4363 return(stuffString(""));
4364 #ifndef SUPPORT_UTF8
4365 str[1] = 0;
4366 return(stuffString(str));
4367 #else
4368 return(stuffStringN((char*)cell->contents, utf8_1st_len((char*)cell->contents)));
4369 #endif
4370 }
4371
4372 else if(isList(cell->type))
4373 return(copyCell((CELL *)cell->contents));
4374 else if(cell->type == CELL_ARRAY)
4375 return(copyCell(*(CELL * *)cell->contents));
4376
4377 return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, params));
4378 }
4379
4380
4381 CELL * p_rest(CELL * params)
4382 {
4383 CELL * cell;
4384 CELL * tail;
4385
4386 cell = evaluateExpression(params);
4387 if(cell->type == CELL_STRING)
4388 {
4389 if(*(char *)cell->contents == 0)
4390 return(stuffString(""));
4391 #ifndef SUPPORT_UTF8
4392 return(stuffString((char *)(cell->contents + 1)));
4393 #else
4394 return(stuffString((char *)(cell->contents + utf8_1st_len((char *)cell->contents))));
4395 #endif
4396 }
4397
4398 else if(isList(cell->type))
4399 {
4400 tail = getCell(CELL_EXPRESSION);
4401 tail->contents = (UINT)copyList(((CELL*)cell->contents)->next);
4402 return(tail);
4403 }
4404 else if(cell->type == CELL_ARRAY)
4405 return(subarray(cell, 1, MAX_LONG));
4406
4407 return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, params));
4408 }
4409
4410 CELL * implicitNrestSlice(CELL * num, CELL * params)
4411 {
4412 CELL * list;
4413 CELL * rest;
4414 ssize_t n, len;
4415
4416 getIntegerExt(num, (UINT *)&n, FALSE);
4417 list = evaluateExpression(params);
4418
4419 if(list->type == CELL_CONTEXT)
4420 list = (CELL *)(translateCreateSymbol(
4421 ((SYMBOL*)list->contents)->name,
4422 CELL_NIL,
4423 (SYMBOL*)list->contents,
4424 TRUE))->contents;
4425
4426 /* slice */
4427 if(isNumber(list->type))
4428 {
4429 getIntegerExt(list, (UINT*)&len, FALSE);
4430 list = evaluateExpression(params->next);
4431
4432 if(list->type == CELL_CONTEXT)
4433 list = (CELL *)(translateCreateSymbol(
4434 ((SYMBOL*)list->contents)->name,
4435 CELL_NIL,
4436 (SYMBOL*)list->contents,
4437 TRUE))->contents;
4438
4439 if(isList(list->type))
4440 return(sublist((CELL *)list->contents, n, len));
4441 else if(list->type == CELL_STRING)
4442 return(substring((char *)list->contents, list->aux-1, n, len));
4443 else if(list->type == CELL_ARRAY)
4444 return(subarray(list, n, len));
4445 }
4446
4447 /* nrest lists */
4448 else if(isList(list->type))
4449 {
4450 list = (CELL *)list->contents;
4451
4452 if(n < 0) n = convertNegativeOffset(n, list);
4453
4454 while(n-- && list != nilCell)
4455 list = list->next;
4456
4457 rest = getCell(CELL_EXPRESSION);
4458 rest->contents = (UINT)copyList(list);
4459 return(rest);
4460 }
4461
4462 /* nrest strings
4463 this was UTF-8 sensitive before 9.1.11, but only the
4464 explicit first/last/rest should be UTF8-sensitive
4465 */
4466 else if(list->type == CELL_STRING)
4467 return(substring((char *)list->contents, list->aux - 1, n, MAX_LONG));
4468
4469 else if(list->type == CELL_ARRAY)
4470 return(subarray(list, n, MAX_LONG));
4471
4472 return(errorProcExt(ERR_ILLEGAL_TYPE, params));
4473 }
4474
4475
4476 CELL * p_cons(CELL * params)
4477 {
4478 CELL * cons;
4479 CELL * head;
4480 CELL * tail;
4481
4482 if(params == nilCell)
4483 return(getCell(CELL_EXPRESSION));
4484
4485 head = copyCell(evaluateExpression(params));
4486
4487 cons = getCell(CELL_EXPRESSION);
4488 cons->contents = (UINT)head;
4489 params = params->next;
4490
4491 if(params != nilCell)
4492 {
4493 tail = evaluateExpression(params);
4494
4495 if(isList(tail->type))
4496 {
4497 if(params->next != nilCell)
4498 {
4499 if(((CELL*)params->next)->contents == -1)
4500 {
4501 cons->contents = (UINT)copyList((CELL *)tail->contents);
4502 tail = (CELL*)cons->contents;
4503 while(tail->next != nilCell)
4504 tail = tail->next;
4505 tail->next = head;
4506 return(cons);
4507 }
4508 }
4509 head->next = copyList((CELL *)tail->contents);
4510 cons->type = tail->type;
4511 }
4512 else
4513 head->next = copyCell(tail);
4514 }
4515
4516 return(cons);
4517 }
4518
4519
4520
4521 CELL * p_list(CELL * params)
4522 {
4523 CELL * list;
4524 CELL * lastCopy;
4525 CELL * copy;
4526 CELL * cell;
4527 int resultIdxSave;
4528
4529 list = getCell(CELL_EXPRESSION);
4530 lastCopy = NULL;
4531
4532 resultIdxSave = resultStackIdx;
4533 while(params != nilCell)
4534 {
4535 cell = evaluateExpression(params);
4536 if(cell->type == CELL_ARRAY)
4537 copy = arrayList(cell);
4538 else
4539 copy = copyCell(cell);
4540 if(copy != nilCell)
4541 {
4542 if(lastCopy == NULL)
4543 list->contents = (UINT)copy;
4544 else lastCopy->next = copy;
4545 }
4546 params = params->next;
4547 lastCopy = copy;
4548 cleanupResults(resultIdxSave);
4549 }
4550
4551 return(list);
4552 }
4553
4554
4555
4556 CELL * p_last(CELL * params)
4557 {
4558 CELL * list;
4559 CELL * listptr;
4560 char * str;
4561 #ifdef SUPPORT_UTF8
4562 char * ptr;
4563 int len;
4564 #endif
4565
4566 list = evaluateExpression(params);
4567 if(list->type == CELL_STRING)
4568 {
4569 str = (char *)list->contents;
4570 #ifndef SUPPORT_UTF8
4571 return(stuffString(str + list->aux - 2));
4572 #else
4573 ptr = str;
4574 while((len = utf8_1st_len(str)) != 0)
4575 {
4576 ptr = str;
4577 str += len;
4578 }
4579 return(stuffStringN(ptr, utf8_1st_len(ptr)));
4580 #endif
4581 }
4582
4583 else if(isList(list->type))
4584 {
4585 if(list->aux != (UINT)nilCell) return(copyCell((CELL *)list->aux));
4586 listptr = (CELL *)list->contents;
4587 while(listptr->next != nilCell) listptr = listptr->next;
4588 list->aux = (UINT)listptr;
4589 return(copyCell(listptr));
4590 }
4591
4592 else if(list->type == CELL_ARRAY)
4593 return(copyCell(*((CELL * *)list->contents + (list->aux - 1) / sizeof(UINT) - 1)));
4594
4595 return(errorProcExt(ERR_ARRAY_LIST_OR_STRING_EXPECTED, params));
4596 }
4597
4598
4599 /* -------------------------- program flow and logical ------------------ */
4600
4601 CELL * evaluateBlock(CELL * cell)
4602 {
4603 CELL * result;
4604
4605 result = nilCell;
4606
4607 while(cell != nilCell)
4608 {
4609 result = evaluateExpression(cell);
4610 cell = cell->next;
4611 }
4612 return(result);
4613 }
4614
4615
4616 CELL * p_if(CELL * params)
4617 {
4618 CELL * cell;
4619
4620 cell = evaluateExpression(params);
4621 while(isNil(cell) || isEmpty(cell))
4622 {
4623 params = params->next;
4624 if(params->next == nilCell)
4625 return(copyCell(cell));
4626 params = params->next;
4627 cell = evaluateExpression(params);
4628 }
4629
4630 if(params->next == nilCell) return(copyCell(cell));
4631
4632 return((copyCell(evaluateExpression(params->next))));
4633 }
4634
4635
4636 CELL * p_when(CELL * params)
4637 {
4638 CELL * cell;
4639
4640 cell = evaluateExpression(params);
4641 if(isNil(cell) || isEmpty(cell)) return(nilCell);
4642
4643 while(params->next != nilCell)
4644 {
4645 cell = evaluateExpression(params->next);
4646 params = params->next;
4647 }
4648
4649 return(copyCell(cell));
4650 }
4651
4652
4653 CELL * p_unless(CELL * params)
4654 {
4655 CELL * cell;
4656
4657 cell = evaluateExpression(params);
4658 if(!isNil(cell) && !isEmpty(cell))
4659 params = params->next;
4660
4661 return((copyCell(evaluateExpression(params->next))));
4662 }
4663
4664
4665 CELL * p_condition(CELL * params)
4666 {
4667 CELL * condition;
4668 CELL * eval = nilCell;
4669
4670 while(params != nilCell)
4671 {
4672 if(params->type == CELL_EXPRESSION)
4673 {
4674 condition = (CELL *)params->contents;
4675 eval = evaluateExpression(condition);
4676 if(!isNil(eval) && !isEmpty(eval))
4677 {
4678 if(condition->next != nilCell)
4679 return(copyCell(evaluateBlock(condition->next)));
4680 return(copyCell(eval));
4681 }
4682 params = params->next;
4683 }
4684 else return(errorProc(ERR_LIST_EXPECTED));
4685 }
4686
4687 return(copyCell(eval));
4688 }
4689
4690
4691 CELL * p_case(CELL * params)
4692 {
4693 CELL * cases;
4694 CELL * cond;
4695
4696 cases = params->next;
4697 params = evaluateExpression(params);
4698 while(cases != nilCell)
4699 {
4700 if(cases->type == CELL_EXPRESSION)
4701 {
4702 cond = (CELL *)cases->contents;
4703 if(compareCells(params, cond) == 0
4704 || (cond->type == CELL_SYMBOL && symbolType((SYMBOL *)cond->contents) == CELL_TRUE)
4705 || cond->type == CELL_TRUE)
4706 return(copyCell(evaluateBlock(cond->next)));
4707 }
4708 cases = cases->next;
4709 }
4710 return(nilCell);
4711 }
4712
4713 #define REPEAT_WHILE 0
4714 #define REPEAT_DOWHILE 1
4715 #define REPEAT_UNTIL 2
4716 #define REPEAT_DOUNTIL 3
4717
4718 CELL * p_while(CELL * params) { return(repeat(params, REPEAT_WHILE)); }
4719 CELL * p_doWhile(CELL * params) { return(repeat(params, REPEAT_DOWHILE)); }
4720 CELL * p_until(CELL * params) { return(repeat(params, REPEAT_UNTIL)); }
4721 CELL * p_doUntil(CELL * params) { return(repeat(params, REPEAT_DOUNTIL)); }
4722
4723 CELL * repeat(CELL * params, int type)
4724 {
4725 CELL * result;
4726 CELL * cell;
4727 int resultIdxSave;
4728
4729 resultIdxSave = resultStackIdx;
4730 result = nilCell;
4731 while(TRUE)
4732 {
4733 switch(type)
4734 {
4735 case REPEAT_WHILE:
4736 cell = evaluateExpression(params);
4737 if(isNil(cell) || isEmpty(cell)) goto END_REPEAT;
4738 cleanupResults(resultIdxSave);
4739 result = evaluateBlock(params->next);
4740 continue;
4741 case REPEAT_DOWHILE:
4742 result = evaluateBlock(params->next);
4743 cell = evaluateExpression(params);
4744 if(isNil(cell) || isEmpty(cell)) goto END_REPEAT;
4745 cleanupResults(resultIdxSave);
4746 continue;
4747 case REPEAT_UNTIL:
4748 cell = evaluateExpression(params);
4749 if(!isNil(cell) && !isEmpty(cell)) goto END_REPEAT;
4750 cleanupResults(resultIdxSave);
4751 result = evaluateBlock(params->next);
4752 continue;
4753 case REPEAT_DOUNTIL:
4754 result = evaluateBlock(params->next);
4755 cell = evaluateExpression(params);
4756 if(!isNil(cell) && !isEmpty(cell)) goto END_REPEAT;
4757 cleanupResults(resultIdxSave);
4758 continue;
4759 default:
4760 break;
4761 }
4762 }
4763 END_REPEAT:
4764 return(copyCell(result));
4765 }
4766
4767 #ifdef from_8_8_4_to_9_0_10
4768 CELL * repeat(CELL * params, int type)
4769 {
4770 CELL * result;
4771 CELL * cell;
4772 int resultIdxSave;
4773
4774 resultIdxSave = resultStackIdx;
4775 result = nilCell;
4776 while(TRUE)
4777 {
4778 switch(type)
4779 {
4780 case REPEAT_WHILE:
4781 cell = evaluateExpression(params);
4782 if(isNil(cell) || isEmpty(cell)) goto END_REPEAT;
4783 cleanupResults(resultIdxSave);
4784 deleteList(result);
4785 result = copyCell(evaluateBlock(params->next));
4786 continue;
4787 case REPEAT_DOWHILE:
4788 deleteList(result);
4789 result = copyCell(evaluateBlock(params->next));
4790 cell = evaluateExpression(params);
4791 if(isNil(cell) || isEmpty(cell)) goto END_REPEAT;
4792 cleanupResults(resultIdxSave);
4793 continue;
4794 case REPEAT_UNTIL:
4795 cell = evaluateExpression(params);
4796 if(!isNil(cell) && !isEmpty(cell)) goto END_REPEAT;
4797 cleanupResults(resultIdxSave);
4798 deleteList(result);
4799 result = copyCell(evaluateBlock(params->next));
4800 continue;
4801 case REPEAT_DOUNTIL:
4802 deleteList(result);
4803 result = copyCell(evaluateBlock(params->next));
4804 cell = evaluateExpression(params);
4805 if(!isNil(cell) && !isEmpty(cell)) goto END_REPEAT;
4806 cleanupResults(resultIdxSave);
4807 continue;
4808 default:
4809 break;
4810 }
4811
4812 }
4813
4814 END_REPEAT:
4815
4816 return(result);
4817 }
4818 #endif
4819
4820
4821 CELL * getPushSymbolParam(CELL * params, SYMBOL * * sym)
4822 {
4823 SYMBOL * symbol;
4824 CELL * cell;
4825
4826 if(params->type != CELL_EXPRESSION)
4827 return(errorProcExt(ERR_LIST_EXPECTED, params));
4828
4829 cell = (CELL *)params->contents;
4830 if(cell->type != CELL_SYMBOL)
4831 return(errorProcExt(ERR_SYMBOL_EXPECTED, cell));
4832
4833 *sym = symbol = (SYMBOL *)cell->contents;
4834 if(isProtected(symbol->flags))
4835 return(errorProcExt2(ERR_SYMBOL_PROTECTED, stuffSymbol(symbol)));
4836
4837 pushEnvironment((CELL *)symbol->contents);
4838 pushEnvironment((UINT)symbol);
4839 symbol->contents = (UINT)nilCell;
4840
4841 return(cell->next);
4842 }
4843
4844 CELL * loop(CELL * params, int forFlag)
4845 {
4846 CELL * cell;
4847 CELL * cond = nilCell;
4848 CELL * block;
4849 SYMBOL * symbol;
4850 double fromFlt, toFlt, interval, step, cntFlt;
4851 INT64 stepCnt, i;
4852 INT64 fromInt64, toInt64;
4853 int intFlag;
4854 int resultIdxSave;
4855
4856 cell = getPushSymbolParam(params, &symbol);
4857
4858 /* integer loops for dotimes and (for (i from to) ...) */
4859 if((intFlag = ((CELL *)cell->next)->next == nilCell))
4860 {
4861 if(forFlag)
4862 {
4863 cell = getInteger64(cell, &fromInt64);
4864 getInteger64(cell, &toInt64);
4865 stepCnt = (toInt64 > fromInt64) ? toInt64 - fromInt64 : fromInt64 - toInt64;
4866 }
4867 else /* dotimes */
4868 {
4869 fromInt64 = toInt64 = 0;
4870 cond = getInteger64(cell, &stepCnt);
4871 }
4872 }
4873 else /* float (for (i from to step) ...) */
4874 {
4875 cell = getFloat(cell, &fromFlt);
4876 cell = getFloat(cell, &toFlt);
4877 cond = getFloat(cell, &step);
4878 if(isnan(fromFlt) || isnan(toFlt) || isnan(step))
4879 return(errorProc(ERR_INVALID_PARAMETER_NAN));
4880 if(step < 0) step = -step;
4881 if(fromFlt > toFlt) step = -step;
4882 cntFlt = (fromFlt < toFlt) ? (toFlt - fromFlt)/step : (fromFlt - toFlt)/step;
4883 stepCnt = (cntFlt > 0.0) ? floor(cntFlt + 0.0000000001) : floor(-cntFlt + 0.0000000001);
4884 }
4885
4886 block = params->next;
4887 resultIdxSave = resultStackIdx;
4888 cell = nilCell;
4889 for(i = 0; i <= stepCnt; i++)
4890 {
4891 if(!forFlag && i == stepCnt) break;
4892 deleteList((CELL *)symbol->contents);
4893 if(intFlag)
4894 {
4895 symbol->contents =
4896 (UINT)stuffInteger64((fromInt64 > toInt64) ? fromInt64 - i:
4897 fromInt64 + i);
4898 }
4899 else
4900 {
4901 interval = fromFlt + i * step;
4902 symbol->contents = (UINT)stuffFloat(&interval);
4903 }
4904 cleanupResults(resultIdxSave);
4905 if(cond != nilCell)
4906 {
4907 cell = evaluateExpression(cond);
4908 if(!isNil(cell)) break;
4909 }
4910 cell = evaluateBlock(block);
4911 }
4912
4913 cell = copyCell(cell);
4914 deleteList((CELL *)symbol->contents);
4915 symbol = (SYMBOL*)popEnvironment();
4916 symbol->flags &= ~SYMBOL_PROTECTED;
4917 symbol->contents = (UINT)popEnvironment();
4918
4919 return(cell);
4920 }
4921
4922
4923 CELL * p_dotimes(CELL * params)
4924 {
4925 return(loop(params, 0));
4926 }
4927
4928 CELL * p_for(CELL * params)
4929 {
4930 return(loop(params, 1));
4931 }
4932
4933
4934 #define DOLIST 0
4935 #define DOARGS 1
4936 #define DOSTRING 2
4937
4938 CELL * p_dolist(CELL * params)
4939 {
4940 return(dolist(params, DOLIST));
4941 }
4942
4943 CELL * p_doargs(CELL * params)
4944 {
4945 return(dolist(params, DOARGS));
4946 }
4947
4948 CELL * p_dostring(CELL * params)
4949 {
4950 return(dolist(params, DOSTRING));
4951 }
4952
4953 CELL * dolist(CELL * params, int doType)
4954 {
4955 CELL * cell;
4956 CELL * list = nilCell;
4957 char * str;
4958 #ifdef SUPPORT_UTF8
4959 int chr;
4960 #endif
4961 CELL * cond = nilCell;
4962 SYMBOL * symbol;
4963 CELL * cellIdx;
4964 int resultIdxSave;
4965
4966 cell = getPushSymbolParam(params, &symbol);
4967
4968 pushEnvironment(dolistIdxSymbol->contents);
4969 pushEnvironment(dolistIdxSymbol);
4970 cellIdx = stuffInteger(0);
4971 dolistIdxSymbol->contents = (UINT)cellIdx;
4972
4973 switch(doType)
4974 {
4975 case DOLIST:
4976 list = copyCell(evaluateExpression(cell));
4977 if(!isList(list->type))
4978 return(errorProcExt(ERR_LIST_EXPECTED, cell));
4979 cond = cell->next;
4980 break;
4981 case DOARGS:
4982 list = copyCell((CELL *)argsSymbol->contents);
4983 cond = cell;
4984 break;
4985 case DOSTRING:
4986 getString(cell, &str);
4987 resultIdxSave = resultStackIdx;
4988 cond = cell->next;
4989 while(*str)
4990 {
4991 cleanupResults(resultIdxSave);
4992 deleteList((CELL *)symbol->contents);
4993 #ifdef SUPPORT_UTF8
4994 str = utf8_wchar(str, &chr);
4995 symbol->contents = (UINT)stuffInteger(chr);
4996 #else
4997 symbol->contents = (UINT)stuffInteger((int)*str++);
4998 #endif
4999 if(cond != nilCell)
5000 {
5001 cell = evaluateExpression(cond);
5002 if(!isNil(cell)) break;
5003 }
5004 cell = evaluateBlock(params->next);
5005 cellIdx->contents += 1;
5006 }
5007 goto FINISH_DO;
5008 break;
5009 }
5010
5011 /* make sure worklist gets destroyed */
5012 pushResult(list);
5013 list = (CELL *)list->contents;
5014
5015 resultIdxSave = resultStackIdx;
5016 cell = nilCell;
5017 while(list!= nilCell)
5018 {
5019 cleanupResults(resultIdxSave);
5020 deleteList((CELL *)symbol->contents);
5021 symbol->contents = (UINT)copyCell(list);
5022 if(cond != nilCell)
5023 {
5024 cell = evaluateExpression(cond);
5025 if(!isNil(cell)) break;
5026 }
5027 cell = evaluateBlock(params->next);
5028 cellIdx->contents += 1;
5029 list = list->next;
5030 }
5031
5032 FINISH_DO:
5033 pushResult(cellIdx);
5034 cell = copyCell(cell);
5035 dolistIdxSymbol = (SYMBOL*)popEnvironment();
5036 dolistIdxSymbol->contents = (UINT)popEnvironment();
5037 deleteList((CELL *)symbol->contents);
5038 symbol = (SYMBOL*)popEnvironment();
5039 symbol->contents = (UINT)popEnvironment();
5040
5041 return(cell);
5042 }
5043
5044
5045 CELL * p_evalBlock(CELL * params)
5046 {
5047 return(copyCell(evaluateBlock(params)));
5048 }
5049
5050
5051 CELL * p_silent(CELL * params)
5052 {
5053 evalSilent = TRUE;
5054
5055 return(copyCell(evaluateBlock(params)));
5056 }
5057
5058
5059 CELL * p_and(CELL * params)
5060 {
5061 CELL * result = nilCell;
5062
5063 while(params != nilCell)
5064 {
5065 result = evaluateExpression(params);
5066 if(isNil(result) || isEmpty(result)) return(copyCell(result));
5067 params = params->next;
5068 }
5069
5070 return(copyCell(result));
5071 }
5072
5073
5074 CELL * p_or(CELL * params)
5075 {
5076 CELL * result = nilCell;
5077
5078 while(params != nilCell)
5079 {
5080 result = evaluateExpression(params);
5081 if(!isNil(result) && !isEmpty(result))
5082 return(copyCell(result));
5083 params = params->next;
5084 }
5085
5086 return(copyCell(result));
5087 }
5088
5089
5090 CELL * p_not(CELL * params)
5091 {
5092 CELL * eval;
5093
5094 eval = evaluateExpression(params);
5095 if(isNil(eval) || isEmpty(eval))
5096 return(trueCell);
5097 return(nilCell);
5098 }
5099
5100
5101
5102 /* ------------------------------ I / O --------------------------------- */
5103
5104 CELL * p_print(CELL * params)
5105 {
5106 return println(params, FALSE);
5107 }
5108
5109
5110 CELL * p_println(CELL * params)
5111 {
5112 return println(params, TRUE);
5113 }
5114
5115
5116 CELL * println(CELL * params, int lineFeed)
5117 {
5118 CELL * result;
5119
5120 result = nilCell;
5121 while(params != nilCell)
5122 {
5123 result = evaluateExpression(params);
5124 if(printCell(result, 0, OUT_DEVICE) == 0)
5125 return(nilCell);
5126 params = params->next;
5127 }
5128
5129 if(lineFeed) varPrintf(OUT_DEVICE, LINE_FEED);
5130
5131 return(copyCell(result));
5132 }
5133
5134
5135 CELL * p_device(CELL * params)
5136 {
5137 if(params != nilCell)
5138 getInteger(params, &printDevice);
5139 return(stuffInteger(printDevice));
5140 }
5141
5142
5143 CELL * p_load(CELL * params)
5144 {
5145 char * fileName;
5146 CELL * result = nilCell;
5147 CELL * next;
5148 SYMBOL * context;
5149 int count = 0;
5150
5151 /* get last parameter */
5152 if((next = params) == nilCell)
5153 errorProc(ERR_MISSING_ARGUMENT);
5154 while(next->next != nilCell)
5155 {
5156 count++;
5157 next = next->next;
5158 }
5159
5160 next = evaluateExpression(next);
5161 if(next->type == CELL_STRING)
5162 {
5163 count++;
5164 context = mainContext;
5165 }
5166 else
5167 {
5168 if(count == 0)
5169 errorProcExt(ERR_STRING_EXPECTED, next);
5170 if((context = getCreateContext(next, FALSE)) == NULL)
5171 errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, next);
5172 next = NULL;
5173 }
5174
5175 while(count--)
5176 {
5177 /* if last arg was a string, avoid double evaluation */
5178 if(count == 0 && next != NULL)
5179 getStringSize(next, &fileName, NULL, FALSE);
5180 else
5181 params = getString(params, &fileName);
5182
5183 result = loadFile(fileName, 0, 0, context);
5184
5185 if(result == NULL)
5186 return(errorProcExt2(ERR_ACCESSING_FILE, stuffString(fileName)));
5187 }
5188
5189 return(result);
5190 }
5191
5192
5193 void saveContext(SYMBOL * sPtr, UINT device)
5194 {
5195 SYMBOL * contextSave;
5196
5197 contextSave = currentContext;
5198
5199 currentContext = sPtr;
5200
5201 if(sPtr != mainContext)
5202 varPrintf(device, "%s(context '%s)%s%s",
5203 LINE_FEED, sPtr->name, LINE_FEED, LINE_FEED);
5204
5205
5206 saveSymbols((SYMBOL *)((CELL*)sPtr->contents)->aux, device);
5207
5208 if(sPtr != mainContext)
5209 varPrintf(device, "%s(context 'MAIN)%s%s",
5210 LINE_FEED, LINE_FEED, LINE_FEED);
5211
5212 currentContext = contextSave;
5213 }
5214
5215
5216 void saveSymbols(SYMBOL * sPtr, UINT device)
5217 {
5218 int type;
5219
5220 if(sPtr != NIL_SYM && sPtr != NULL)
5221 {
5222 saveSymbols(sPtr->left, device);
5223 type = symbolType(sPtr);
5224 if(type == CELL_CONTEXT)
5225 {
5226 if(sPtr == (SYMBOL *)((CELL *)sPtr->contents)->contents)
5227 {
5228 if(sPtr != currentContext) saveContext(sPtr, device);
5229 }
5230 else printSymbol(sPtr, device);
5231 }
5232 else if(type != CELL_PRIMITIVE && type != CELL_NIL
5233 && sPtr != trueSymbol && type != CELL_IMPORT_CDECL
5234 && sPtr != argsSymbol
5235 #ifdef WIN_32
5236 && type != CELL_IMPORT_DLL
5237 #endif
5238 )
5239 if(*sPtr->name != '$') printSymbol(sPtr, device);
5240 saveSymbols(sPtr->right, device);
5241 }
5242 }
5243
5244
5245 CELL * p_save(CELL * params)
5246 {
5247 char * fileName;
5248 STREAM strStream;
5249 UINT printDeviceSave;
5250 CELL * result;
5251 SYMBOL * contextSave;
5252 CELL * dataCell;
5253
5254 contextSave = currentContext;
5255 currentContext = mainContext;
5256 printDeviceSave = printDevice;
5257
5258 params = getString(params, &fileName);
5259
5260 /* check for URL format */
5261 if(my_strnicmp(fileName, "http://", 7) == 0)
5262 {
5263 openStrStream(&strStream, MAX_STRING, 0);
5264 serializeSymbols(params, (UINT)&strStream);
5265 dataCell = stuffString(strStream.buffer);
5266 result = getPutPostDeleteUrl(fileName, dataCell, HTTP_PUT_URL, 60000);
5267 closeStrStream(&strStream);
5268 deleteList(dataCell);
5269 return(result);
5270 }
5271 else
5272 {
5273 if(my_strnicmp(fileName, "file://", 7) == 0)
5274 fileName = fileName + 7;
5275 if( (printDevice = (UINT)openFile(fileName, "write", NULL)) == (UINT)-1)
5276 return(errorProcExt2(ERR_SAVING_FILE, stuffString(fileName)));
5277 serializeSymbols(params, OUT_DEVICE);
5278 close((int)printDevice);
5279 }
5280
5281 currentContext = contextSave;
5282 printDevice = printDeviceSave;
5283 return(trueCell);
5284 }
5285
5286 void serializeSymbols(CELL * params, UINT device)
5287 {
5288 SYMBOL * sPtr;
5289
5290 if(params->type == CELL_NIL)
5291 saveSymbols((SYMBOL *)((CELL*)currentContext->contents)->aux, device);
5292 else
5293 while(params != nilCell)
5294 {
5295 params = getSymbol(params, &sPtr);
5296 if(symbolType(sPtr) == CELL_CONTEXT)
5297 saveContext((SYMBOL*)((CELL *)sPtr->contents)->contents, device);
5298 else
5299 printSymbol(sPtr, device);
5300 }
5301 }
5302
5303 /* ----------------------- copy a context with 'new' -------------- */
5304 static SYMBOL * fromContext;
5305 static SYMBOL * newContext;
5306 static int overWriteFlag;
5307
5308 CELL * copyContextList(CELL * cell);
5309 UINT * copyContextArray(CELL * array);
5310
5311
5312 CELL * copyContextCell(CELL * cell)
5313 {
5314 CELL * newCell;
5315 SYMBOL * sPtr;
5316 SYMBOL * newSptr;
5317
5318 if(firstFreeCell == NULL) allocBlock();
5319 newCell = firstFreeCell;
5320 firstFreeCell = newCell->next;
5321 ++cellCount;
5322
5323 newCell->type = cell->type;
5324 newCell->next = nilCell;
5325 newCell->aux = cell->aux;
5326 newCell->contents = cell->contents;
5327
5328 if(cell->type == CELL_DYN_SYMBOL)
5329 {
5330 sPtr = (SYMBOL*)cell->aux;
5331 if(sPtr->context == fromContext)
5332 newCell->aux =
5333 (UINT)translateCreateSymbol(sPtr->name, 0, newContext, TRUE);
5334 newCell->contents = (UINT)allocMemory(strlen((char *)cell->contents) + 1);
5335 memcpy((void *)newCell->contents,
5336 (void*)cell->contents, strlen((char *)cell->contents) + 1);
5337 }
5338
5339 if(cell->type == CELL_SYMBOL)
5340 {
5341 /* if the cell copied itself contains a symbol copy it recursevely,
5342 if new, if not done here it might not been seen as new later and left
5343 without contents */
5344 sPtr = (SYMBOL *)cell->contents;
5345 if(sPtr->context == fromContext && !(sPtr->flags & SYMBOL_BUILTIN))
5346 {
5347 if((newSptr = lookupSymbol(sPtr->name, newContext)) == NULL)
5348 {
5349 newSptr = translateCreateSymbol(sPtr->name, symbolType(sPtr), newContext, TRUE);
5350 newSptr->contents = (UINT)copyContextCell((CELL*)sPtr->contents);
5351 }
5352 newCell->contents = (UINT)newSptr;
5353 }
5354 }
5355
5356 if(isEnvelope(cell->type))
5357 {
5358 if(cell->type == CELL_ARRAY)
5359 newCell->contents = (UINT)copyContextArray(cell);
5360 else
5361 newCell->contents = (UINT)copyContextList((CELL *)cell->contents);
5362 }
5363
5364 else if(cell->type == CELL_STRING)
5365 {
5366 newCell->contents = (UINT)allocMemory((UINT)cell->aux);
5367 memcpy((void *)newCell->contents,
5368 (void*)cell->contents, (UINT)cell->aux);
5369 }
5370
5371 return(newCell);
5372 }
5373
5374
5375 CELL * copyContextList(CELL * cell)
5376 {
5377 CELL * firstCell;
5378 CELL * newCell;
5379
5380 if(cell == nilCell || cell == trueCell) return(cell);
5381
5382 firstCell = newCell = copyContextCell(cell);
5383
5384 while((cell = cell->next) != nilCell)
5385 {
5386 newCell->next = copyContextCell(cell);
5387 newCell = newCell->next;
5388 }
5389
5390 return(firstCell);
5391 }
5392
5393
5394 UINT * copyContextArray(CELL * array)
5395 {
5396 CELL * * newAddr;
5397 CELL * * orgAddr;
5398 CELL * * addr;
5399 size_t size;
5400
5401 addr = newAddr = (CELL * *)callocMemory(array->aux);
5402
5403 size = (array->aux - 1) / sizeof(UINT);
5404 orgAddr = (CELL * *)array->contents;
5405
5406 while(size--)
5407 *(newAddr++) = copyContextCell(*(orgAddr++));
5408
5409 return((UINT*)addr);
5410 }
5411
5412
5413 void iterateSymbols(SYMBOL * sPtr)
5414 {
5415 int type, newFlag = FALSE;
5416 SYMBOL * newPtr;
5417
5418 if(sPtr != NIL_SYM && sPtr != NULL && !(sPtr->flags & SYMBOL_BUILTIN))
5419 {
5420 iterateSymbols(sPtr->left);
5421 type = symbolType(sPtr);
5422
5423 /* check for default symbol */
5424 if(*sPtr->name == *fromContext->name && strcmp(sPtr->name, fromContext->name) == 0)
5425 {
5426 if((newPtr = lookupSymbol(newContext->name, newContext)) == NULL)
5427 {
5428 newPtr = translateCreateSymbol(newContext->name, type, newContext, TRUE);
5429 newFlag = TRUE;
5430 }
5431 }
5432 else
5433 {
5434 if((newPtr = lookupSymbol(sPtr->name, newContext)) == NULL)
5435 {
5436 newPtr = translateCreateSymbol(sPtr->name, type, newContext, TRUE);
5437 newFlag = TRUE;
5438 }
5439 }
5440
5441 if(overWriteFlag == TRUE || newFlag == TRUE)
5442 {
5443 deleteList((CELL *)newPtr->contents);
5444 newPtr->contents = (UINT)copyContextCell((CELL*)sPtr->contents);
5445 }
5446
5447 iterateSymbols(sPtr->right);
5448 }
5449 }
5450
5451
5452
5453 CELL * p_new(CELL * params)
5454 {
5455 CELL * next;
5456
5457 overWriteFlag = FALSE;
5458
5459 params = getContext(params, &fromContext);
5460 if(!fromContext) return(nilCell); /* for debug mode */
5461
5462 next = params->next;
5463
5464 if(params == nilCell)
5465 newContext = currentContext;
5466 else
5467 {
5468 params = evaluateExpression(params);
5469 if(params->type == CELL_CONTEXT || params->type == CELL_SYMBOL)
5470 newContext = (SYMBOL *)params->contents;
5471 else
5472 return(errorProcExt(ERR_CONTEXT_EXPECTED, params));
5473
5474 overWriteFlag = (evaluateExpression(next)->type != CELL_NIL);
5475
5476 /* allow symbols to be converted to contexts */
5477 if(symbolType(newContext) != CELL_CONTEXT)
5478 {
5479 if(isProtected(newContext->flags))
5480 return(errorProcExt(ERR_SYMBOL_PROTECTED, params));
5481
5482 if(newContext->context != mainContext)
5483 return(errorProcExt2(ERR_NOT_IN_MAIN, stuffSymbol(newContext)));
5484
5485 deleteList((CELL *)newContext->contents);
5486 makeContextFromSymbol(newContext, NULL);
5487 }
5488 }
5489
5490 if(newContext == mainContext)
5491 return(errorProc(ERR_TARGET_NO_MAIN));
5492
5493 iterateSymbols((SYMBOL *)((CELL*)fromContext->contents)->aux);
5494
5495 return(copyCell((CELL*)newContext->contents));
5496 }
5497
5498
5499 CELL * p_defineNew(CELL * params)
5500 {
5501 SYMBOL * sourcePtr;
5502 SYMBOL * targetPtr;
5503 char * name;
5504
5505 params = getSymbol(params, &sourcePtr);
5506 if(params != nilCell)
5507 {
5508 params = getSymbol(params, &targetPtr);
5509 name = targetPtr->name;
5510 newContext = targetPtr->context;
5511 }
5512 else
5513 {
5514 name = sourcePtr->name;
5515 newContext = currentContext;
5516 }
5517
5518 if(newContext == mainContext)
5519 return(errorProc(ERR_TARGET_NO_MAIN));
5520
5521 fromContext = sourcePtr->context;
5522 targetPtr = translateCreateSymbol(name, symbolType(sourcePtr), newContext, TRUE);
5523
5524 deleteList((CELL *)targetPtr->contents);
5525 targetPtr->contents = (UINT)copyContextCell((CELL*)sourcePtr->contents);
5526
5527 return(stuffSymbol(targetPtr));
5528 }
5529
5530
5531
5532 /* ------------------------------ system ------------------------------ */
5533
5534 CELL * isType(CELL *, int);
5535
5536 CELL * p_isNil(CELL * params)
5537 {
5538 if(isNil(evaluateExpression(params)))
5539 return(trueCell);
5540
5541 return(nilCell);
5542 }
5543
5544 CELL * p_isEmpty(CELL * params)
5545 {
5546 return(isEmptyFunc(evaluateExpression(params)));
5547 }
5548
5549 CELL * isEmptyFunc(CELL * cell)
5550 {
5551 if(cell->type == CELL_STRING)
5552 {
5553 if(*(char*)cell->contents == 0)
5554 return(trueCell);
5555 else return(nilCell);
5556 }
5557
5558 if(!isList(cell->type))
5559 return(errorProcExt(ERR_LIST_OR_STRING_EXPECTED, cell));
5560 if(cell->contents == (UINT)nilCell)
5561 return(trueCell);
5562 return(nilCell);
5563 }
5564
5565 CELL * isZero(CELL * cell)
5566 {
5567 #ifndef NEWLISP64
5568 if(cell->type == CELL_INT64)
5569 {
5570 if(*(INT64 *)&cell->aux == 0)
5571 return(trueCell);
5572 else
5573 return(nilCell);
5574 }
5575 #endif
5576
5577 if(cell->type == CELL_FLOAT)
5578 {
5579 #ifndef NEWLISP64
5580 if(*(double *)&cell->aux == 0.0)
5581 #else
5582 if(*(double *)&cell->contents == 0.0)
5583 #endif
5584 return(trueCell);
5585 else
5586 return(nilCell);
5587 }
5588
5589 if(cell->type == CELL_LONG)
5590 {
5591 if(cell->contents == 0)
5592 return(trueCell);
5593 }
5594
5595 return(nilCell);
5596 }
5597
5598
5599 CELL * p_isNull(CELL * params)
5600 {
5601 CELL * cell;
5602
5603 cell = evaluateExpression(params);
5604 if(isNil(cell))
5605 return(trueCell);
5606
5607 if( (cell->type == CELL_STRING || isList(cell->type)))
5608 return(isEmptyFunc(cell));
5609
5610 #ifndef NEWLISP64
5611 if(cell->type == CELL_FLOAT && (isnan(*(double *)&cell->aux)) )
5612 #else
5613 if(cell->type == CELL_FLOAT && (isnan(*(double *)&cell->contents)))
5614 #endif
5615 return(trueCell);
5616
5617 return(isZero(cell));
5618 }
5619
5620
5621 CELL * p_isZero(CELL * params)
5622 {
5623 params = evaluateExpression(params);
5624 return(isZero(params));
5625 }
5626
5627
5628 CELL * p_isTrue(CELL * params)
5629 {
5630 params = evaluateExpression(params);
5631 if(!isNil(params) && !isEmpty(params))
5632 return(trueCell);
5633
5634 return(nilCell);
5635 }
5636
5637 CELL * p_isInteger(CELL * params)
5638 {
5639 params = evaluateExpression(params);
5640 if((params->type & COMPARE_TYPE_MASK) == CELL_INT)
5641 return(trueCell);
5642 return(nilCell);
5643 }
5644
5645
5646 CELL * p_isFloat(CELL * params)
5647 { return(isType(params, CELL_FLOAT)); }
5648
5649 CELL * p_isNumber(CELL * params)
5650 {
5651 params = evaluateExpression(params);
5652 if(isNumber(params->type)) return(trueCell);
5653 return(nilCell);
5654 }
5655
5656 CELL * p_isString(CELL * params)
5657 { return(isType(params, CELL_STRING)); }
5658
5659 CELL * p_isSymbol(CELL * params)
5660 { return(isType(params, CELL_SYMBOL)); }
5661
5662 CELL * p_isContext(CELL * params)
5663 {
5664 char * symStr;
5665 SYMBOL * ctx;
5666
5667 /* check type */
5668 if(params->next == nilCell)
5669 return(isType(params, CELL_CONTEXT));
5670
5671 /* check for existense of symbol */
5672 params = getContext(params, &ctx);
5673 if(!ctx) return(nilCell); /* for debug mode */
5674 getString(params, &symStr);
5675
5676 return (lookupSymbol(symStr, ctx) ? trueCell : nilCell);
5677 }
5678
5679 CELL * p_isPrimitive(CELL * params)
5680 { return(isType(params, CELL_PRIMITIVE)); }
5681
5682
5683 CELL * p_isGlobal(CELL * params)
5684 {
5685 params = evaluateExpression(params);
5686 if(isSymbol(params->type) && isGlobal(((SYMBOL *)params->contents)->flags))
5687 return(trueCell);
5688 return(nilCell);
5689 }
5690
5691 CELL * p_isProtected(CELL * params)
5692 {
5693 params = evaluateExpression(params);
5694 if(isSymbol(params->type) && isProtected(((SYMBOL *)params->contents)->flags))
5695 return(trueCell);
5696 return(nilCell);
5697 }
5698
5699 CELL * p_isAtom(CELL * params)
5700 {
5701 if(params == nilCell)
5702 return(errorProc(ERR_MISSING_ARGUMENT));
5703 params = evaluateExpression(params);
5704 if(params->type & ENVELOPE_TYPE_MASK) return(nilCell);
5705 return(trueCell);
5706 }
5707
5708 CELL * p_isQuote(CELL *params)
5709 { return(isType(params, CELL_QUOTE)); }
5710
5711 CELL * p_isList(CELL * params)
5712 { return(isType(params, CELL_EXPRESSION)); }
5713
5714 CELL * p_isLambda(CELL * params)
5715 { return(isType(params, CELL_LAMBDA)); }
5716
5717 CELL * p_isMacro(CELL * params)
5718 { return(isType(params, CELL_MACRO)); }
5719
5720 CELL * p_isArray(CELL * params)
5721 { return(isType(params, CELL_ARRAY)); }
5722
5723 CELL * isType(CELL * params, int operand)
5724 {
5725 CELL * contextCell;
5726
5727 if(params == nilCell)
5728 return(errorProc(ERR_MISSING_ARGUMENT));
5729 params = evaluateExpression(params);
5730 if((UINT)operand == params->type) return(trueCell);
5731 switch(operand)
5732 {
5733 case CELL_PRIMITIVE:
5734 if(params->type == CELL_IMPORT_CDECL
5735 #ifdef WIN_32
5736 || params->type == CELL_IMPORT_DLL
5737 #endif
5738 )
5739 return(trueCell);
5740 break;
5741 case CELL_EXPRESSION:
5742 if(isList(params->type)) return(trueCell);
5743 break;
5744 case CELL_SYMBOL:
5745 if(params->type == CELL_DYN_SYMBOL) /* check if already created */
5746 {
5747 contextCell = (CELL *)((SYMBOL *)params->aux)->contents;
5748 if(contextCell->type != CELL_CONTEXT)
5749 fatalError(ERR_CONTEXT_EXPECTED,
5750 stuffSymbol((SYMBOL*)params->aux), TRUE);
5751 if(lookupSymbol((char *)params->contents, (SYMBOL*)contextCell->contents))
5752 return(trueCell);
5753 }
5754
5755 break;
5756 default:
5757 break;
5758 }
5759
5760 return(nilCell);
5761 }
5762
5763
5764 CELL * p_isLegal(CELL * params)
5765 {
5766 char * symStr;
5767
5768 getString(params, &symStr);
5769
5770 if(isLegalSymbol(symStr)) return(trueCell);
5771
5772 return(nilCell);
5773 }
5774
5775
5776 int isLegalSymbol(char * source)
5777 {
5778 STREAM stream;
5779 char token[MAX_SYMBOL + 1];
5780 int tklen;
5781
5782 if(*source == (char)'"' || *source == (char)'{' || *source == (char)'['
5783 || (unsigned char)*source <= (unsigned char)' ' || *source == (char)';' || *source == (char)'#')
5784 return(0);
5785
5786 makeStreamFromString(&stream, source);
5787
5788 return( (getToken(&stream, token, &tklen) == TKN_SYMBOL) && tklen == strlen(source));
5789 }
5790
5791
5792 CELL * p_exit(CELL * params)
5793 {
5794 UINT result;
5795
5796 if(demonMode)
5797 {
5798 fclose(IOchannel);
5799 #ifndef WIN_32
5800 IOchannel = NULL;
5801 #endif
5802 longjmp(errorJump, ERR_USER_RESET);
5803 }
5804
5805 if(params != nilCell) getInteger(params, (UINT*)&result);
5806 else result = 0;
5807 exit(result);
5808 return(trueCell);
5809 }
5810
5811
5812
5813 CELL * p_reset(CELL * params)
5814 {
5815 #ifndef LIBRARY
5816 #ifndef WIN_32
5817 if (getFlag(params))
5818 execv(MainArgs[0], MainArgs);
5819 #endif
5820 #endif
5821
5822 longjmp(errorJump, ERR_USER_RESET);
5823 return(nilCell);
5824 }
5825
5826
5827 CELL * p_errorEvent(CELL * params)
5828 {
5829 CELL * symCell;
5830
5831 if(params != nilCell) getCreateSymbol(params, &errorEvent, "$error-event");
5832 symCell = getCell(CELL_SYMBOL);
5833 symCell->contents = (UINT)errorEvent;
5834 return(symCell);
5835 }
5836
5837 #ifndef WIN_32
5838
5839 CELL * p_timerEvent(CELL * params)
5840 {
5841 CELL * symCell;
5842 double seconds;
5843 UINT timerOption = 0;
5844 struct itimerval timerVal;
5845 struct itimerval outVal;
5846 static double duration;
5847
5848 if(params != nilCell)
5849 {
5850 params = getCreateSymbol(params, &timerEvent, "$timer");
5851
5852 if(params != nilCell)
5853 {
5854 params = getFloat(params, &seconds);
5855 duration = seconds;
5856 if(params != nilCell)
5857 getInteger(params, (UINT*)&timerOption);
5858 memset(&timerVal, 0, sizeof(timerVal));
5859 timerVal.it_value.tv_sec = seconds;
5860 timerVal.it_value.tv_usec = (seconds - timerVal.it_value.tv_sec) * 1000000;
5861 if(setitimer((int)timerOption, &timerVal, &outVal) == -1)
5862 return(nilCell);
5863 return(stuffInteger(0));
5864 }
5865 else
5866 getitimer(timerOption, &outVal);
5867
5868 seconds = duration - (outVal.it_value.tv_sec + outVal.it_value.tv_usec / 1000000.0);
5869 return(stuffFloat(&seconds));
5870 }
5871
5872 symCell = getCell(CELL_SYMBOL);
5873 symCell->contents = (UINT)timerEvent;
5874 return(symCell);
5875 }
5876 #endif
5877
5878 CELL * p_signal(CELL * params)
5879 {
5880 CELL * symCell;
5881 SYMBOL * signalEvent;
5882 UINT sig;
5883 char sigStr[12];
5884
5885 params = getInteger(params, (UINT *)&sig);
5886 if(sig > 32 || sig < 1) return(nilCell);
5887
5888 if(params != nilCell)
5889 {
5890 if(isNil(params))
5891 {
5892 signal(sig, SIG_IGN);
5893 symHandler[sig - 1] = nilSymbol;
5894 }
5895 else if(isTrue(params))
5896 {
5897 signal(sig, SIG_DFL);
5898 symHandler[sig - 1] = trueSymbol;
5899 }
5900 else
5901 {
5902 snprintf(sigStr, 11, "$signal-%ld", sig);
5903 getCreateSymbol(params, &signalEvent, sigStr);
5904 symHandler[sig - 1] = signalEvent;
5905 if(signal(sig, signal_handler) == SIG_ERR)
5906 return(nilCell);
5907 }
5908 }
5909
5910 symCell = getCell(CELL_SYMBOL);
5911 symCell->contents = (UINT)symHandler[sig - 1];
5912 return(symCell);
5913 }
5914
5915
5916 CELL * p_errorNumber(CELL * params)
5917 {
5918 return(stuffInteger((UINT)errorReg));
5919 }
5920
5921
5922 CELL * p_errorText(CELL * params)
5923 {
5924 UINT errorNumber = errorReg;
5925
5926 if(params == nilCell)
5927 {
5928 if(errorStream.buffer != NULL)
5929 return(stuffString(errorStream.buffer));
5930 }
5931 else
5932 getInteger(params, &errorNumber);
5933
5934
5935 if(errorNumber > MAX_ERROR_NUMBER)
5936 errorNumber = ERR_NUMBER_OUT_OF_RANGE;
5937
5938 return(stuffString(errorMessage[errorNumber]));
5939 }
5940
5941
5942
5943 CELL * p_dump(CELL * params)
5944 {
5945 CELL * blockPtr;
5946 int i;
5947 CELL * cell;
5948
5949 if(params != nilCell)
5950 {
5951 cell = evaluateExpression(params);
5952 return(stuffIntegerList
5953 (5, cell, cell->type, cell->next, cell->aux, cell->contents));
5954 }
5955
5956 blockPtr = cellMemory;
5957 while(blockPtr != NULL)
5958 {
5959 for(i = 0; i < MAX_BLOCK; i++)
5960 {
5961 if(*(UINT *)blockPtr != CELL_FREE)
5962 {
5963 varPrintf(OUT_DEVICE, "address=%lX type=%d contents=", blockPtr, blockPtr->type);
5964 printCell(blockPtr, TRUE, OUT_DEVICE);
5965 varPrintf(OUT_DEVICE,LINE_FEED);
5966 }
5967 ++blockPtr;
5968 }
5969 blockPtr = blockPtr->next;
5970 }
5971 return(trueCell);
5972 }
5973
5974
5975 CELL * p_mainArgs(CELL * params)
5976 {
5977 CELL * cell;
5978 ssize_t idx;
5979
5980 cell = (CELL*)mainArgsSymbol->contents;
5981 if(params != nilCell)
5982 {
5983 getInteger(params, (UINT *)&idx);
5984 cell = (CELL *)cell->contents;
5985 if(idx < 0) idx = convertNegativeOffset(idx, (CELL *)cell);
5986 while(idx--) cell = cell->next;
5987 }
5988
5989 return(copyCell(cell));
5990 }
5991
5992
5993 CELL * p_context(CELL * params)
5994 {
5995 CELL * cell;
5996 SYMBOL * sPtr;
5997 SYMBOL * cPtr;
5998 char * newSymStr;
5999
6000 if(params->type == CELL_NIL)
6001 return(copyCell((CELL *)currentContext->contents));
6002
6003 if((cPtr = getCreateContext(params, TRUE)) == NULL)
6004 return(errorProcExt(ERR_SYMBOL_OR_CONTEXT_EXPECTED, params));
6005
6006 if(params->next == nilCell)
6007 {
6008 currentContext = cPtr;
6009 return(copyCell( (CELL *)currentContext->contents));
6010 }
6011
6012 params = params->next;
6013 cell = evaluateExpression(params);
6014 if(cell->type == CELL_STRING)
6015 newSymStr = (char *)cell->contents;
6016 else if(cell->type == CELL_SYMBOL)
6017 newSymStr = ((SYMBOL *)cell->contents)->name;
6018 else if(cell->type == CELL_DYN_SYMBOL)
6019 {
6020 sPtr = getDynamicSymbol(cell);
6021 newSymStr = sPtr->name;
6022 }
6023 else
6024 return(errorProcExt(ERR_ILLEGAL_TYPE, cell));
6025
6026 sPtr = translateCreateSymbol(newSymStr, CELL_NIL, cPtr, TRUE);
6027 if(params->next == nilCell)
6028 {
6029 pushResultFlag = FALSE;
6030 return((CELL *)sPtr->contents);
6031 }
6032
6033 if(strcmp(cPtr->name, sPtr->name) == 0)
6034 return(nilCell);
6035
6036 return(setDefine(sPtr, params->next, TYPE_SET));
6037 }
6038
6039
6040 SYMBOL * getCreateContext(CELL * cell, int evaluate)
6041 {
6042 SYMBOL * contextSymbol;
6043
6044 if(evaluate)
6045 cell = evaluateExpression(cell);
6046
6047 if(cell->type == CELL_SYMBOL || cell->type == CELL_CONTEXT)
6048 contextSymbol = (SYMBOL *)cell->contents;
6049 else
6050 return(NULL);
6051
6052
6053 if(symbolType(contextSymbol) != CELL_CONTEXT)
6054 {
6055 if(isProtected(contextSymbol->flags))
6056 return(NULL);
6057
6058 if(contextSymbol->context != mainContext)
6059 {
6060 contextSymbol= translateCreateSymbol(
6061 contextSymbol->name, CELL_CONTEXT, mainContext, 1);
6062 }
6063
6064 if(symbolType(contextSymbol) != CELL_CONTEXT)
6065 {
6066 if(isProtected(contextSymbol->flags))
6067 errorProcExt(ERR_CONTEXT_EXPECTED, stuffSymbol(contextSymbol));
6068
6069 deleteList((CELL *)contextSymbol->contents);
6070 makeContextFromSymbol(contextSymbol, NULL);
6071 }
6072 }
6073
6074 /* if this is a context var retrieve the real context symbol */
6075 return((SYMBOL *)((CELL *)contextSymbol->contents)->contents);
6076 }
6077
6078
6079 CELL * p_default(CELL * params)
6080 {
6081 SYMBOL * contextSymbol;
6082
6083 getContext(params, &contextSymbol);
6084
6085 return(stuffSymbol(translateCreateSymbol(contextSymbol->name, CELL_NIL, contextSymbol, TRUE)));
6086 }
6087
6088 CELL * p_colon(CELL * params)
6089 {
6090 SYMBOL * contextSymbol = NULL;
6091 SYMBOL * methodSymbol;
6092 CELL * proc;
6093 CELL * cell;
6094 CELL * obj;
6095 CELL * quote;
6096
6097 if(params->type != CELL_SYMBOL)
6098 return(errorProcExt(ERR_SYMBOL_EXPECTED, params));
6099
6100 methodSymbol = (SYMBOL *)params->contents;
6101 params = params->next;
6102 obj = evaluateExpression(params);
6103 if(obj->type != CELL_EXPRESSION)
6104 return(errorProcExt(ERR_LIST_EXPECTED, obj));
6105 cell = (CELL *)obj->contents;
6106
6107 if(cell->type == CELL_SYMBOL || cell->type == CELL_CONTEXT)
6108 contextSymbol = (SYMBOL *)cell->contents;
6109 if(contextSymbol == NULL || symbolType(contextSymbol) != CELL_CONTEXT)
6110 return(errorProcExt(ERR_CONTEXT_EXPECTED, cell));
6111
6112 if((methodSymbol = lookupSymbol(methodSymbol->name, contextSymbol)) == NULL)
6113 return(errorProc(ERR_INVALID_FUNCTION));
6114
6115 proc = getCell(CELL_EXPRESSION);
6116 proc->contents = (UINT)stuffSymbol(methodSymbol);
6117 quote = getCell(CELL_QUOTE);
6118 quote->contents = (UINT)copyCell(obj);
6119 cell = (CELL *)proc->contents;
6120 cell->next = quote;
6121 cell = quote;
6122 params = params->next;
6123 while(params != nilCell)
6124 {
6125 cell->next = copyCell(params);
6126 cell = cell->next;
6127 params = params->next;
6128 }
6129
6130 pushResult(proc);
6131 return(copyCell(evaluateExpression(proc)));
6132 }
6133
6134
6135 CELL * p_systemSymbol(CELL * params)
6136 {
6137 UINT idx;
6138
6139 getInteger(params, &idx);
6140
6141 if(idx > 15 || idx < 0) return(nilCell);
6142
6143 return(copyCell((CELL*)sysSymbol[idx]->contents));
6144 }
6145
6146
6147 /* end of file */
Git mirror of development version of newLISP.