Context Navigation

source: abuse/trunk/src/lisp/lisp.cpp @ 554
Tweet

Last change on this file since 554 was 554, checked in by Sam Hocevar, 11 years ago
lisp: if the Lisp permanent space grows out of memory, grow the space during GCs instead of dying.
File size: 81.4 KB

Line
1	/*
2	* Abuse - dark 2D side-scrolling platform game
3	* Copyright (c) 1995 Crack dot Com
4	* Copyright (c) 2005-2011 Sam Hocevar <sam@hocevar.net>
5	*
6	* This software was released into the Public Domain. As with most public
7	* domain software, no warranty is made or implied by Crack dot Com or
8	* Jonathan Clark.
9	*/
10
11	#include "config.h"
12
13	#include <stdio.h>
14	#include <ctype.h>
15	#include <stdlib.h>
16	#include <string.h>
17	#include <stdarg.h>
18
19	#include "common.h"
20
21	#define TYPE_CHECKING 1
22
23	#include "lisp.h"
24	#include "lisp_gc.h"
25	#include "symbols.h"
26
27	#ifdef NO_LIBS
28	# include "fakelib.h"
29	#else
30	# include "status.h"
31	# include "specs.h"
32	# include "dprint.h"
33	# include "cache.h"
34	# include "dev.h"
35	#endif
36
37	/* To bypass the whole garbage collection issue of lisp I am going to have
38	* separate spaces where lisp objects can reside. Compiled code and gloabal
39	* variables will reside in permanant space. Eveything else will reside in
40	* tmp space which gets thrown away after completion of eval. system
41	* functions reside in permant space. */
42
43	bFILE *current_print_file=NULL;
44
45	LSymbol *LSymbol::root = NULL;
46	size_t LSymbol::count = 0;
47
48
49	uint8_t space[4], free_space[4];
50	size_t space_size[4];
51	int print_level = 0, trace_level = 0, trace_print_level = 1000;
52	int total_user_functions;
53
54	int current_space; // normally set to TMP_SPACE, unless compiling or other needs
55
56	int break_level=0;
57
58	void l1print(void *block)
59	{
60	if(!block \|\| item_type(block) != L_CONS_CELL)
61	{
62	((LObject *)block)->Print();
63	return;
64	}
65
66	dprintf("(");
67	for( ; block && item_type(block) == L_CONS_CELL; block = CDR(block))
68	{
69	void *a = CAR(block);
70	if(item_type(a) == L_CONS_CELL)
71	dprintf("[...]");
72	else
73	((LObject *)a)->Print();
74	}
75	if (block)
76	{
77	dprintf(" . ");
78	((LObject *)block)->Print();
79	}
80	dprintf(")");
81	}
82
83	void where_print(int max_lev = -1)
84	{
85	dprintf("Main program\n");
86	if (max_lev==-1) max_lev=PtrRef::stack.son;
87	else if (max_lev>=PtrRef::stack.son) max_lev=PtrRef::stack.son-1;
88
89	for (int i=0; i<max_lev; i++)
90	{
91	dprintf("%d> ", i);
92	((LObject )PtrRef::stack.sdata[i])->Print();
93	}
94	}
95
96	void print_trace_stack(int max_levels)
97	{
98	where_print(max_levels);
99	}
100
101	void lbreak(char const *format, ...)
102	{
103	break_level++;
104	bFILE *old_file=current_print_file;
105	current_print_file=NULL;
106	char st[300];
107	va_list ap;
108	va_start(ap, format);
109	vsprintf(st, format, ap);
110	va_end(ap);
111	dprintf("%s\n", st);
112	int cont=0;
113	do
114	{
115	dprintf("type q to quit\n");
116	dprintf("%d. Break> ", break_level);
117	dgets(st, 300);
118	if (!strcmp(st, "c") \|\| !strcmp(st, "cont") \|\| !strcmp(st, "continue"))
119	cont=1;
120	else if (!strcmp(st, "w") \|\| !strcmp(st, "where"))
121	where_print();
122	else if (!strcmp(st, "q") \|\| !strcmp(st, "quit"))
123	exit(1);
124	else if (!strcmp(st, "e") \|\| !strcmp(st, "env") \|\| !strcmp(st, "environment"))
125	{
126	dprintf("Enviorment : \nnot supported right now\n");
127
128	}
129	else if (!strcmp(st, "h") \|\| !strcmp(st, "help") \|\| !strcmp(st, "?"))
130	{
131	dprintf("CLIVE Debugger\n");
132	dprintf(" w, where : show calling parents\n"
133	" e, env : show environment\n"
134	" c, cont : continue if possible\n"
135	" q, quit : quits the program\n"
136	" h, help : this\n");
137	}
138	else
139	{
140	char const *s=st;
141	do
142	{
143	LObject *prog = LObject::Compile(s);
144	PtrRef r1(prog);
145	while (s==' ' \|\| s=='\t' \|\| s=='\r' \|\| s=='\n')
146	s++;
147	prog->Eval()->Print();
148	} while (*s);
149	}
150
151	} while (!cont);
152	current_print_file=old_file;
153	break_level--;
154	}
155
156	void need_perm_space(char const *why)
157	{
158	if (current_space!=PERM_SPACE && current_space!=GC_SPACE)
159	{
160	lbreak("%s : action requires permanant space\n", why);
161	exit(0);
162	}
163	}
164
165	void *mark_heap(int heap)
166	{
167	return free_space[heap];
168	}
169
170	void restore_heap(void *val, int heap)
171	{
172	free_space[heap] = (uint8_t *)val;
173	}
174
175	static size_t get_free_size(int which_space)
176	{
177	size_t used = free_space[which_space] - space[which_space];
178	return space_size[which_space] > used ? space_size[which_space] - used : 0;
179	}
180
181	static void *lmalloc(size_t size, int which_space)
182	{
183	// Align allocation
184	size = (size + sizeof(intptr_t) - 1) & ~(sizeof(intptr_t) - 1);
185
186	// Collect garbage if necessary
187	if (size > get_free_size(which_space))
188	{
189	if (which_space == PERM_SPACE \|\| which_space == TMP_SPACE)
190	collect_space(which_space, 0);
191
192	if (size > get_free_size(which_space))
193	collect_space(which_space, 1);
194
195	if (size > get_free_size(which_space))
196	{
197	lbreak("lisp: cannot find %d bytes in space #%d\n",
198	size, which_space);
199	exit(0);
200	}
201	}
202
203	void ret = (void )free_space[which_space];
204	free_space[which_space] += size;
205	return ret;
206	}
207
208	void eval_block(void list)
209	{
210	PtrRef r1(list);
211	void *ret=NULL;
212	while (list)
213	{
214	ret = CAR(list)->Eval();
215	list = CDR(list);
216	}
217	return ret;
218	}
219
220	LArray LArray::Create(size_t len, void rest)
221	{
222	PtrRef r11(rest);
223	size_t size = sizeof(LArray) + (len - 1) * sizeof(LObject *);
224	if (size < sizeof(LRedirect))
225	size = sizeof(LRedirect);
226
227	LArray p = (LArray )lmalloc(size, current_space);
228	p->type = L_1D_ARRAY;
229	p->len = len;
230	LObject **data = p->GetData();
231	memset(data, 0, len * sizeof(LObject *));
232	PtrRef r1(p);
233
234	if (rest)
235	{
236	LObject *x = CAR(rest)->Eval();
237	if (x == colon_initial_contents)
238	{
239	x = CAR(CDR(rest))->Eval();
240	data = p->GetData();
241	for (size_t i = 0; i < len; i++, x = CDR(x))
242	{
243	if (!x)
244	{
245	((LObject *)rest)->Print();
246	lbreak("(make-array) incorrect list length\n");
247	exit(0);
248	}
249	data[i] = (LObject *)CAR(x);
250	}
251	if (x)
252	{
253	((LObject *)rest)->Print();
254	lbreak("(make-array) incorrect list length\n");
255	exit(0);
256	}
257	}
258	else if (x == colon_initial_element)
259	{
260	x = CAR(CDR(rest))->Eval();
261	data = p->GetData();
262	for (size_t i = 0; i < len; i++)
263	data[i] = (LObject *)x;
264	}
265	else
266	{
267	((LObject *)x)->Print();
268	lbreak("Bad option argument to make-array\n");
269	exit(0);
270	}
271	}
272
273	return p;
274	}
275
276	LFixedPoint *LFixedPoint::Create(int32_t x)
277	{
278	size_t size = sizeof(LFixedPoint);
279	if (size < sizeof(LRedirect))
280	size = sizeof(LRedirect);
281
282	LFixedPoint p = (LFixedPoint )lmalloc(size, current_space);
283	p->type = L_FIXED_POINT;
284	p->x = x;
285	return p;
286	}
287
288	LObjectVar *LObjectVar::Create(int index)
289	{
290	size_t size = sizeof(LObjectVar);
291	if (size < sizeof(LRedirect))
292	size = sizeof(LRedirect);
293
294	LObjectVar p = (LObjectVar )lmalloc(size, current_space);
295	p->type = L_OBJECT_VAR;
296	p->index = index;
297	return p;
298	}
299
300	LPointer LPointer::Create(void addr)
301	{
302	if (addr == NULL)
303	return NULL;
304	size_t size = sizeof(LPointer);
305	if (size < sizeof(LRedirect))
306	size = sizeof(LRedirect);
307
308	LPointer p = (LPointer )lmalloc(size, current_space);
309	p->type = L_POINTER;
310	p->addr = addr;
311	return p;
312	}
313
314	LChar *LChar::Create(uint16_t ch)
315	{
316	size_t size = sizeof(LChar);
317	if (size < sizeof(LRedirect))
318	size = sizeof(LRedirect);
319
320	LChar c = (LChar )lmalloc(size, current_space);
321	c->type = L_CHARACTER;
322	c->ch = ch;
323	return c;
324	}
325
326	struct LString LString::Create(char const string)
327	{
328	LString *s = Create(strlen(string) + 1);
329	strcpy(s->str, string);
330	return s;
331	}
332
333	struct LString LString::Create(char const string, int length)
334	{
335	LString *s = Create(length + 1);
336	memcpy(s->str, string, length);
337	s->str[length] = 0;
338	return s;
339	}
340
341	struct LString *LString::Create(int length)
342	{
343	size_t size = sizeof(LString) + length - 1;
344	if (size < sizeof(LRedirect))
345	size = sizeof(LRedirect);
346
347	LString s = (LString )lmalloc(size, current_space);
348	s->type = L_STRING;
349	s->str[0] = '\0';
350	return s;
351	}
352
353	LUserFunction new_lisp_user_function(LList arg_list, LList *block_list)
354	{
355	PtrRef r1(arg_list), r2(block_list);
356
357	size_t size = sizeof(LUserFunction);
358	if (size < sizeof(LRedirect))
359	size = sizeof(LRedirect);
360
361	LUserFunction lu = (LUserFunction )lmalloc(size, current_space);
362	lu->type = L_USER_FUNCTION;
363	lu->arg_list = arg_list;
364	lu->block_list = block_list;
365	return lu;
366	}
367
368	LSysFunction *new_lisp_sys_function(int min_args, int max_args, int fun_number)
369	{
370	size_t size = sizeof(LSysFunction);
371	if (size < sizeof(LRedirect))
372	size = sizeof(LRedirect);
373
374	// System functions should reside in permanant space
375	int space = (current_space == GC_SPACE) ? GC_SPACE : PERM_SPACE;
376	LSysFunction ls = (LSysFunction )lmalloc(size, space);
377	ls->type = L_SYS_FUNCTION;
378	ls->min_args = min_args;
379	ls->max_args = max_args;
380	ls->fun_number = fun_number;
381	return ls;
382	}
383
384	LSysFunction *new_lisp_c_function(int min_args, int max_args, int fun_number)
385	{
386	LSysFunction *ls = new_lisp_sys_function(min_args, max_args, fun_number);
387	ls->type = L_C_FUNCTION;
388	return ls;
389	}
390
391	LSysFunction *new_lisp_c_bool(int min_args, int max_args, int fun_number)
392	{
393	LSysFunction *ls = new_lisp_sys_function(min_args, max_args, fun_number);
394	ls->type = L_C_BOOL;
395	return ls;
396	}
397
398	LSysFunction *new_user_lisp_function(int min_args, int max_args, int fun_number)
399	{
400	LSysFunction *ls = new_lisp_sys_function(min_args, max_args, fun_number);
401	ls->type = L_L_FUNCTION;
402	return ls;
403	}
404
405	LSymbol new_lisp_symbol(char name)
406	{
407	size_t size = sizeof(LSymbol);
408	if (size < sizeof(LRedirect))
409	size = sizeof(LRedirect);
410
411	LSymbol s = (LSymbol )lmalloc(size, current_space);
412	s->type = L_SYMBOL;
413	s->name = LString::Create(name);
414	s->value = l_undefined;
415	s->function = l_undefined;
416	#ifdef L_PROFILE
417	s->time_taken = 0;
418	#endif
419	return s;
420	}
421
422	LNumber *LNumber::Create(long num)
423	{
424	size_t size = sizeof(LNumber);
425	if (size < sizeof(LRedirect))
426	size = sizeof(LRedirect);
427
428	LNumber n = (LNumber )lmalloc(size, current_space);
429	n->type = L_NUMBER;
430	n->num = num;
431	return n;
432	}
433
434	LList *LList::Create()
435	{
436	size_t size = sizeof(LList);
437	if (size < sizeof(LRedirect))
438	size = sizeof(LRedirect);
439
440	LList c = (LList )lmalloc(size, current_space);
441	c->type = L_CONS_CELL;
442	c->car = NULL;
443	c->cdr = NULL;
444	return c;
445	}
446
447	char lerror(char const loc, char const *cause)
448	{
449	int lines;
450	if (loc)
451	{
452	for (lines=0; *loc && lines<10; loc++)
453	{
454	if (*loc=='\n') lines++;
455	dprintf("%c", *loc);
456	}
457	dprintf("\nPROGRAM LOCATION : \n");
458	}
459	if (cause)
460	dprintf("ERROR MESSAGE : %s\n", cause);
461	lbreak("");
462	exit(0);
463	return NULL;
464	}
465
466	void nth(int num, void list)
467	{
468	if (num<0)
469	{
470	lbreak("NTH: %d is not a nonnegative fixnum and therefore not a valid index\n", num);
471	exit(1);
472	}
473
474	while (list && num)
475	{
476	list=CDR(list);
477	num--;
478	}
479	if (!list) return NULL;
480	else return CAR(list);
481	}
482
483	void lpointer_value(void lpointer)
484	{
485	if (!lpointer) return NULL;
486	#ifdef TYPE_CHECKING
487	else if (item_type(lpointer)!=L_POINTER)
488	{
489	((LObject *)lpointer)->Print();
490	lbreak(" is not a pointer\n");
491	exit(0);
492	}
493	#endif
494	return ((LPointer *)lpointer)->addr;
495	}
496
497	int32_t lnumber_value(void *lnumber)
498	{
499	switch (item_type(lnumber))
500	{
501	case L_NUMBER :
502	return ((LNumber *)lnumber)->num;
503	case L_FIXED_POINT :
504	return (((LFixedPoint *)lnumber)->x)>>16;
505	case L_STRING :
506	return (uint8_t)*lstring_value(lnumber);
507	case L_CHARACTER :
508	return lcharacter_value(lnumber);
509	default :
510	{
511	((LObject *)lnumber)->Print();
512	lbreak(" is not a number\n");
513	exit(0);
514	}
515	}
516	return 0;
517	}
518
519	char *LString::GetString()
520	{
521	#ifdef TYPE_CHECKING
522	if (item_type(this) != L_STRING)
523	{
524	Print();
525	lbreak(" is not a string\n");
526	exit(0);
527	}
528	#endif
529	return str;
530	}
531
532	void lisp_atom(void i)
533	{
534	if (item_type(i)==(ltype)L_CONS_CELL)
535	return NULL;
536	else return true_symbol;
537	}
538
539	LObject lcdr(void c)
540	{
541	if (!c) return NULL;
542	else if (item_type(c)==(ltype)L_CONS_CELL)
543	return ((LList *)c)->cdr;
544	else
545	return NULL;
546	}
547
548	LObject lcar(void c)
549	{
550	if (!c) return NULL;
551	else if (item_type(c)==(ltype)L_CONS_CELL)
552	return ((LList *)c)->car;
553	else return NULL;
554	}
555
556	uint16_t lcharacter_value(void *c)
557	{
558	#ifdef TYPE_CHECKING
559	if (item_type(c)!=L_CHARACTER)
560	{
561	((LObject *)c)->Print();
562	lbreak("is not a character\n");
563	exit(0);
564	}
565	#endif
566	return ((LChar *)c)->ch;
567	}
568
569	long lfixed_point_value(void *c)
570	{
571	switch (item_type(c))
572	{
573	case L_NUMBER :
574	return ((LNumber *)c)->num<<16; break;
575	case L_FIXED_POINT :
576	return (((LFixedPoint *)c)->x); break;
577	default :
578	{
579	((LObject *)c)->Print();
580	lbreak(" is not a number\n");
581	exit(0);
582	}
583	}
584	return 0;
585	}
586
587	void lisp_eq(void n1, void *n2)
588	{
589	if (!n1 && !n2) return true_symbol;
590	else if ((n1 && !n2) \|\| (n2 && !n1)) return NULL;
591	{
592	int t1=((ltype )n1), t2=((ltype )n2);
593	if (t1!=t2) return NULL;
594	else if (t1==L_NUMBER)
595	{ if (((LNumber )n1)->num==((LNumber )n2)->num)
596	return true_symbol;
597	else return NULL;
598	} else if (t1==L_CHARACTER)
599	{
600	if (((LChar )n1)->ch==((LChar )n2)->ch)
601	return true_symbol;
602	else return NULL;
603	}
604	else if (n1==n2)
605	return true_symbol;
606	else if (t1==L_POINTER)
607	if (n1==n2) return true_symbol;
608	}
609	return NULL;
610	}
611
612	LObject *LArray::Get(int x)
613	{
614	#ifdef TYPE_CHECKING
615	if (type != L_1D_ARRAY)
616	{
617	Print();
618	lbreak("is not an array\n");
619	exit(0);
620	}
621	#endif
622	if (x >= (int)len \|\| x < 0)
623	{
624	lbreak("array reference out of bounds (%d)\n", x);
625	exit(0);
626	}
627	return data[x];
628	}
629
630	void lisp_equal(void n1, void *n2)
631	{
632	if(!n1 && !n2) // if both nil, then equal
633	return true_symbol;
634
635	if(!n1 \|\| !n2) // one nil, nope
636	return NULL;
637
638	int t1 = item_type(n1), t2 = item_type(n2);
639	if(t1 != t2)
640	return NULL;
641
642	switch (t1)
643	{
644	case L_STRING :
645	if (!strcmp(lstring_value(n1), lstring_value(n2)))
646	return true_symbol;
647	return NULL;
648	case L_CONS_CELL :
649	while (n1 && n2) // loop through the list and compare each element
650	{
651	if (!lisp_equal(CAR(n1), CAR(n2)))
652	return NULL;
653	n1=CDR(n1);
654	n2=CDR(n2);
655	if (n1 && ((ltype )n1)!=L_CONS_CELL)
656	return lisp_equal(n1, n2);
657	}
658	if (n1 \|\| n2)
659	return NULL; // if one is longer than the other
660	return true_symbol;
661	default :
662	return lisp_eq(n1, n2);
663	}
664	}
665
666	int32_t lisp_cos(int32_t x)
667	{
668	x=(x+FIXED_TRIG_SIZE/4)%FIXED_TRIG_SIZE;
669	if (x<0) return sin_table[FIXED_TRIG_SIZE+x];
670	else return sin_table[x];
671	}
672
673	int32_t lisp_sin(int32_t x)
674	{
675	x=x%FIXED_TRIG_SIZE;
676	if (x<0) return sin_table[FIXED_TRIG_SIZE+x];
677	else return sin_table[x];
678	}
679
680	int32_t lisp_atan2(int32_t dy, int32_t dx)
681	{
682	if (dy==0)
683	{
684	if (dx>0) return 0;
685	else return 180;
686	} else if (dx==0)
687	{
688	if (dy>0) return 90;
689	else return 270;
690	} else
691	{
692	if (dx>0)
693	{
694	if (dy>0)
695	{
696	if (abs(dx)>abs(dy))
697	{
698	int32_t a=dx*29/dy;
699	if (a>=TBS) return 0;
700	else return 45-atan_table[a];
701	}
702	else
703	{
704	int32_t a=dy*29/dx;
705	if (a>=TBS) return 90;
706	else return 45+atan_table[a];
707	}
708	} else
709	{
710	if (abs(dx)>abs(dy))
711	{
712	int32_t a=dx*29/abs(dy);
713	if (a>=TBS)
714	return 0;
715	else
716	return 315+atan_table[a];
717	}
718	else
719	{
720	int32_t a=abs(dy)*29/dx;
721	if (a>=TBS)
722	return 260;
723	else
724	return 315-atan_table[a];
725	}
726	}
727	} else
728	{
729	if (dy>0)
730	{
731	if (abs(dx)>abs(dy))
732	{
733	int32_t a=-dx*29/dy;
734	if (a>=TBS)
735	return 135+45;
736	else
737	return 135+atan_table[a];
738	}
739	else
740	{
741	int32_t a=dy*29/-dx;
742	if (a>=TBS)
743	return 135-45;
744	else
745	return 135-atan_table[a];
746	}
747	} else
748	{
749	if (abs(dx)>abs(dy))
750	{
751	int32_t a=-dx*29/abs(dy);
752	if (a>=TBS)
753	return 225-45;
754	else return 225-atan_table[a];
755	}
756	else
757	{
758	int32_t a=abs(dy)*29/abs(dx);
759	if (a>=TBS)
760	return 225+45;
761	else return 225+atan_table[a];
762	}
763	}
764	}
765	}
766	}
767
768
769	/*
770	LSymbol find_symbol(char const name)
771	{
772	LList *cs;
773	for (cs=(LList )symbol_list; cs; cs=(LList )CDR(cs))
774	{
775	if (!strcmp( ((char )((LSymbol )cs->car)->name)+sizeof(LString), name))
776	return (LSymbol *)(cs->car);
777	}
778	return NULL;
779	}
780
781
782	LSymbol make_find_symbol(char const name) // find a symbol, if it doesn't exsist it is created
783	{
784	LSymbol *s=find_symbol(name);
785	if (s) return s;
786	else
787	{
788	int sp=current_space;
789	if (current_space!=GC_SPACE)
790	current_space=PERM_SPACE; // make sure all symbols get defined in permanant space
791	LList *cs;
792	cs=LList::Create();
793	s=new_lisp_symbol(name);
794	cs->car=s;
795	cs->cdr=symbol_list;
796	symbol_list=cs;
797	current_space=sp;
798	}
799	return s;
800	}
801
802	*/
803
804	LSymbol LSymbol::Find(char const name)
805	{
806	LSymbol *p = root;
807	while (p)
808	{
809	int cmp = strcmp(name, p->name->GetString());
810	if (cmp == 0)
811	return p;
812	p = (cmp < 0) ? p->left : p->right;
813	}
814	return NULL;
815	}
816
817	LSymbol LSymbol::FindOrCreate(char const name)
818	{
819	LSymbol *p = root;
820	LSymbol **parent = &root;
821	while (p)
822	{
823	int cmp = strcmp(name, p->name->GetString());
824	if (cmp == 0)
825	return p;
826	parent = (cmp < 0) ? &p->left : &p->right;
827	p = *parent;
828	}
829
830	// Make sure all symbols get defined in permanant space
831	int sp = current_space;
832	if (current_space != GC_SPACE)
833	current_space = PERM_SPACE;
834
835	p = (LSymbol *)malloc(sizeof(LSymbol));
836	p->type = L_SYMBOL;
837	p->name = LString::Create(name);
838
839	// If constant, set the value to ourself
840	p->value = (name[0] == ':') ? p : l_undefined;
841	p->function = l_undefined;
842	#ifdef L_PROFILE
843	p->time_taken = 0;
844	#endif
845	p->left = p->right = NULL;
846	*parent = p;
847	count++;
848
849	current_space = sp;
850	return p;
851	}
852
853	static void DeleteAllSymbols(LSymbol *root)
854	{
855	if (root)
856	{
857	DeleteAllSymbols(root->left);
858	DeleteAllSymbols(root->right);
859	free(root);
860	}
861	}
862
863	void assoc(void item, void *list)
864	{
865	if (item_type(list)!=(ltype)L_CONS_CELL)
866	return NULL;
867	else
868	{
869	while (list)
870	{
871	if (lisp_eq(CAR(CAR(list)), item))
872	return lcar(list);
873	list=(LList *)(CDR(list));
874	}
875	}
876	return NULL;
877	}
878
879	size_t LList::GetLength()
880	{
881	size_t ret = 0;
882
883	#ifdef TYPE_CHECKING
884	if (this && item_type(this) != (ltype)L_CONS_CELL)
885	{
886	Print();
887	lbreak(" is not a sequence\n");
888	exit(0);
889	}
890	#endif
891
892	for (LObject *p = this; p; p = CDR(p))
893	ret++;
894	return ret;
895	}
896
897	void pairlis(void list1, void list2, void list3)
898	{
899	if (item_type(list1)!=(ltype)L_CONS_CELL \|\| item_type(list1)!=item_type(list2))
900	return NULL;
901
902	void *ret=NULL;
903	size_t l1 = ((LList *)list1)->GetLength();
904	size_t l2 = ((LList *)list2)->GetLength();
905
906	if (l1!=l2)
907	{
908	((LObject *)list1)->Print();
909	((LObject *)list2)->Print();
910	lbreak("... are not the same length (pairlis)\n");
911	exit(0);
912	}
913	if (l1!=0)
914	{
915	LList first = NULL, last = NULL, *cur = NULL;
916	LObject *tmp;
917	PtrRef r1(first), r2(last), r3(cur);
918	while (list1)
919	{
920	cur = LList::Create();
921	if (!first)
922	first = cur;
923	if (last)
924	last->cdr = cur;
925	last = cur;
926
927	LList *cell = LList::Create();
928	tmp = (LObject *)lcar(list1);
929	cell->car = tmp;
930	tmp = (LObject *)lcar(list2);
931	cell->cdr = tmp;
932	cur->car = cell;
933
934	list1 = ((LList *)list1)->cdr;
935	list2 = ((LList *)list2)->cdr;
936	}
937	cur->cdr = (LObject *)list3;
938	ret=first;
939	} else ret=NULL;
940	return ret;
941	}
942
943	void LSymbol::SetFunction(LObject *fun)
944	{
945	function = fun;
946	}
947
948	LSymbol add_sys_function(char const name, short min_args, short max_args, short number)
949	{
950	need_perm_space("add_sys_function");
951	LSymbol *s = LSymbol::FindOrCreate(name);
952	if (s->function!=l_undefined)
953	{
954	lbreak("add_sys_fucntion -> symbol %s already has a function\n", name);
955	exit(0);
956	}
957	else s->function=new_lisp_sys_function(min_args, max_args, number);
958	return s;
959	}
960
961	LSymbol add_c_object(void symbol, int index)
962	{
963	need_perm_space("add_c_object");
964	LSymbol s=(LSymbol )symbol;
965	if (s->value!=l_undefined)
966	{
967	lbreak("add_c_object -> symbol %s already has a value\n", lstring_value(s->GetName()));
968	exit(0);
969	}
970	else s->value=LObjectVar::Create(index);
971	return NULL;
972	}
973
974	LSymbol add_c_function(char const name, short min_args, short max_args, short number)
975	{
976	total_user_functions++;
977	need_perm_space("add_c_function");
978	LSymbol *s = LSymbol::FindOrCreate(name);
979	if (s->function!=l_undefined)
980	{
981	lbreak("add_sys_fucntion -> symbol %s already has a function\n", name);
982	exit(0);
983	}
984	else s->function=new_lisp_c_function(min_args, max_args, number);
985	return s;
986	}
987
988	LSymbol add_c_bool_fun(char const name, short min_args, short max_args, short number)
989	{
990	total_user_functions++;
991	need_perm_space("add_c_bool_fun");
992	LSymbol *s = LSymbol::FindOrCreate(name);
993	if (s->function!=l_undefined)
994	{
995	lbreak("add_sys_fucntion -> symbol %s already has a function\n", name);
996	exit(0);
997	}
998	else s->function=new_lisp_c_bool(min_args, max_args, number);
999	return s;
1000	}
1001
1002
1003	LSymbol add_lisp_function(char const name, short min_args, short max_args, short number)
1004	{
1005	total_user_functions++;
1006	need_perm_space("add_c_bool_fun");
1007	LSymbol *s = LSymbol::FindOrCreate(name);
1008	if (s->function!=l_undefined)
1009	{
1010	lbreak("add_sys_fucntion -> symbol %s already has a function\n", name);
1011	exit(0);
1012	}
1013	else s->function=new_user_lisp_function(min_args, max_args, number);
1014	return s;
1015	}
1016
1017	void skip_c_comment(char const *&s)
1018	{
1019	s+=2;
1020	while (s && (s!='' \|\| (s+1)!='/'))
1021	{
1022	if (s=='/' && (s+1)=='*')
1023	skip_c_comment(s);
1024	else s++;
1025	}
1026	if (*s) s+=2;
1027	}
1028
1029	long str_token_len(char const *st)
1030	{
1031	long x=1;
1032	while (st && (st!='"' \|\| st[1]=='"'))
1033	{
1034	if (st=='\\' \|\| st=='"') st++;
1035	st++; x++;
1036	}
1037	return x;
1038	}
1039
1040	int read_ltoken(char const &s, char buffer)
1041	{
1042	// skip space
1043	while (s==' ' \|\| s=='\t' \|\| s=='\n' \|\| s=='\r' \|\| *s==26) s++;
1044	if (*s==';') // comment
1045	{
1046	while (s && s!='\n' && s!='\r' && s!=26) s++;
1047	return read_ltoken(s, buffer);
1048	} else if (s=='/' && (s+1)=='*') // c style comment
1049	{
1050	skip_c_comment(s);
1051	return read_ltoken(s, buffer);
1052	}
1053	else if (*s==0)
1054	return 0;
1055	else if (s==')' \|\| s=='(' \|\| s=='\'' \|\| s=='`' \|\| s==',' \|\| s==26)
1056	{
1057	(buffer++)=(s++);
1058	*buffer=0;
1059	} else if (*s=='"') // string
1060	{
1061	(buffer++)=(s++); // don't read off the string because it
1062	// may be to long to fit in the token buffer
1063	// so just read the '"' so the compiler knows to scan the rest.
1064	*buffer=0;
1065	} else if (*s=='#')
1066	{
1067	(buffer++)=(s++);
1068	if (*s!='\'')
1069	(buffer++)=(s++);
1070	*buffer=0;
1071	} else
1072	{
1073	while (s && s!=')' && s!='(' && s!=' ' && s!='\n' && s!='\r' && s!='\t' && s!=';' && *s!=26)
1074	(buffer++)=(s++);
1075	*buffer=0;
1076	}
1077	return 1;
1078	}
1079
1080
1081	char n[MAX_LISP_TOKEN_LEN]; // assume all tokens will be < 200 characters
1082
1083	int end_of_program(char const *s)
1084	{
1085	return !read_ltoken(s, n);
1086	}
1087
1088
1089	void push_onto_list(void object, void &list)
1090	{
1091	PtrRef r1(object), r2(list);
1092	LList *c = LList::Create();
1093	c->car = (LObject *)object;
1094	c->cdr = (LObject *)list;
1095	list=c;
1096	}
1097
1098	void comp_optimize(void list);
1099
1100	LObject LObject::Compile(char const &code)
1101	{
1102	LObject *ret = NULL;
1103
1104	if (!read_ltoken(code, n))
1105	lerror(NULL, "unexpected end of program");
1106
1107	if (!strcmp(n, "nil"))
1108	return NULL;
1109	else if (toupper(n[0])=='T' && !n[1])
1110	return true_symbol;
1111	else if (n[0]=='\'') // short hand for quote function
1112	{
1113	LObject cs = LList::Create(), c2=NULL, *tmp;
1114	PtrRef r1(cs), r2(c2);
1115
1116	((LList *)cs)->car=quote_symbol;
1117	c2 = LList::Create();
1118	tmp=Compile(code);
1119	((LList )c2)->car = (LObject )tmp;
1120	((LList *)c2)->cdr=NULL;
1121	((LList )cs)->cdr = (LObject )c2;
1122	ret=cs;
1123	}
1124	else if (n[0]=='`') // short hand for backquote function
1125	{
1126	LObject cs = LList::Create(), c2=NULL, *tmp;
1127	PtrRef r1(cs), r2(c2);
1128
1129	((LList *)cs)->car=backquote_symbol;
1130	c2 = LList::Create();
1131	tmp=Compile(code);
1132	((LList )c2)->car = (LObject )tmp;
1133	((LList *)c2)->cdr=NULL;
1134	((LList )cs)->cdr = (LObject )c2;
1135	ret=cs;
1136	} else if (n[0]==',') // short hand for comma function
1137	{
1138	LObject cs = LList::Create(), c2=NULL, *tmp;
1139	PtrRef r1(cs), r2(c2);
1140
1141	((LList *)cs)->car=comma_symbol;
1142	c2 = LList::Create();
1143	tmp=Compile(code);
1144	((LList )c2)->car = (LObject )tmp;
1145	((LList *)c2)->cdr=NULL;
1146	((LList )cs)->cdr = (LObject )c2;
1147	ret=cs;
1148	}
1149	else if (n[0]=='(') // make a list of everything in ()
1150	{
1151	void first=NULL, cur=NULL, *last=NULL;
1152	PtrRef r1(first), r2(cur), r3(last);
1153	int done=0;
1154	do
1155	{
1156	char const *tmp=code;
1157	if (!read_ltoken(tmp, n)) // check for the end of the list
1158	lerror(NULL, "unexpected end of program");
1159	if (n[0]==')')
1160	{
1161	done=1;
1162	read_ltoken(code, n); // read off the ')'
1163	}
1164	else
1165	{
1166	if (n[0]=='.' && !n[1])
1167	{
1168	if (!first)
1169	lerror(code, "token '.' not allowed here\n");
1170	else
1171	{
1172	void *tmp;
1173	read_ltoken(code, n); // skip the '.'
1174	tmp=Compile(code);
1175	((LList )last)->cdr = (LObject )tmp; // link the last cdr to
1176	last=NULL;
1177	}
1178	} else if (!last && first)
1179	lerror(code, "illegal end of dotted list\n");
1180	else
1181	{
1182	void *tmp;
1183	cur = LList::Create();
1184	PtrRef r1(cur);
1185	if (!first) first=cur;
1186	tmp=Compile(code);
1187	((LList )cur)->car = (LObject )tmp;
1188	if (last)
1189	((LList )last)->cdr = (LObject )cur;
1190	last=cur;
1191	}
1192	}
1193	} while (!done);
1194	ret=(LObject *)comp_optimize(first);
1195
1196	} else if (n[0]==')')
1197	lerror(code, "mismatched )");
1198	else if (isdigit(n[0]) \|\| (n[0]=='-' && isdigit(n[1])))
1199	{
1200	LNumber *num = LNumber::Create(0);
1201	sscanf(n, "%ld", &num->num);
1202	ret=num;
1203	} else if (n[0]=='"')
1204	{
1205	ret = LString::Create(str_token_len(code));
1206	char *start=lstring_value(ret);
1207	for (; code && (code!='"' \|\| code[1]=='"'); code++, start++)
1208	{
1209	if (*code=='\\')
1210	{
1211	code++;
1212	if (code=='n') start='\n';
1213	if (code=='r') start='\r';
1214	if (code=='t') start='\t';
1215	if (code=='\\') start='\\';
1216	} else start=code;
1217	if (*code=='"') code++;
1218	}
1219	*start=0;
1220	code++;
1221	} else if (n[0]=='#')
1222	{
1223	if (n[1]=='\\')
1224	{
1225	read_ltoken(code, n); // read character name
1226	if (!strcmp(n, "newline"))
1227	ret = LChar::Create('\n');
1228	else if (!strcmp(n, "space"))
1229	ret = LChar::Create(' ');
1230	else
1231	ret = LChar::Create(n[0]);
1232	}
1233	else if (n[1]==0) // short hand for function
1234	{
1235	LObject cs = LList::Create(), c2=NULL, *tmp;
1236	PtrRef r4(cs), r5(c2);
1237	tmp = LSymbol::FindOrCreate("function");
1238	((LList )cs)->car = (LObject )tmp;
1239	c2 = LList::Create();
1240	tmp=Compile(code);
1241	((LList )c2)->car = (LObject )tmp;
1242	((LList )cs)->cdr = (LObject )c2;
1243	ret=cs;
1244	}
1245	else
1246	{
1247	lbreak("Unknown #\\ notation : %s\n", n);
1248	exit(0);
1249	}
1250	} else {
1251	ret = LSymbol::FindOrCreate(n);
1252	}
1253	return ret;
1254	}
1255
1256
1257	static void lprint_string(char const *st)
1258	{
1259	if (current_print_file)
1260	{
1261	for (char const s=st; s; s++)
1262	{
1263	/* if (*s=='\\')
1264	{
1265	s++;
1266	if (*s=='n')
1267	current_print_file->write_uint8('\n');
1268	else if (*s=='r')
1269	current_print_file->write_uint8('\r');
1270	else if (*s=='t')
1271	current_print_file->write_uint8('\t');
1272	else if (*s=='\\')
1273	current_print_file->write_uint8('\\');
1274	}
1275	else*/
1276	current_print_file->write_uint8(*s);
1277	}
1278	}
1279	else
1280	dprintf(st);
1281	}
1282
1283	void LObject::Print()
1284	{
1285	char buf[32];
1286
1287	print_level++;
1288
1289	switch (item_type(this))
1290	{
1291	case L_CONS_CELL:
1292	if (!this)
1293	{
1294	lprint_string("nil");
1295	}
1296	else
1297	{
1298	LList cs = (LList )this;
1299	lprint_string("(");
1300	for (; cs; cs = (LList *)lcdr(cs))
1301	{
1302	if (item_type(cs) == (ltype)L_CONS_CELL)
1303	{
1304	cs->car->Print();
1305	if (cs->cdr)
1306	lprint_string(" ");
1307	}
1308	else
1309	{
1310	lprint_string(". ");
1311	cs->Print();
1312	cs = NULL;
1313	}
1314	}
1315	lprint_string(")");
1316	}
1317	break;
1318	case L_NUMBER:
1319	sprintf(buf, "%ld", ((LNumber *)this)->num);
1320	lprint_string(buf);
1321	break;
1322	case L_SYMBOL:
1323	lprint_string(((LSymbol *)this)->name->GetString());
1324	break;
1325	case L_USER_FUNCTION:
1326	case L_SYS_FUNCTION:
1327	lprint_string("err... function?");
1328	break;
1329	case L_C_FUNCTION:
1330	lprint_string("C function, returns number\n");
1331	break;
1332	case L_C_BOOL:
1333	lprint_string("C boolean function\n");
1334	break;
1335	case L_L_FUNCTION:
1336	lprint_string("External lisp function\n");
1337	break;
1338	case L_STRING:
1339	if (current_print_file)
1340	lprint_string(lstring_value(this));
1341	else
1342	dprintf("\"%s\"", lstring_value(this));
1343	break;
1344	case L_POINTER:
1345	sprintf(buf, "%p", lpointer_value(this));
1346	lprint_string(buf);
1347	break;
1348	case L_FIXED_POINT:
1349	sprintf(buf, "%g", (lfixed_point_value(this) >> 16) +
1350	((lfixed_point_value(this) & 0xffff)) / (double)0x10000);
1351	lprint_string(buf);
1352	break;
1353	case L_CHARACTER:
1354	if (current_print_file)
1355	{
1356	uint8_t ch = ((LChar *)this)->ch;
1357	current_print_file->write(&ch, 1);
1358	}
1359	else
1360	{
1361	uint16_t ch = ((LChar *)this)->ch;
1362	dprintf("#\\");
1363	switch (ch)
1364	{
1365	case '\n':
1366	dprintf("newline"); break;
1367	case ' ':
1368	dprintf("space"); break;
1369	default:
1370	dprintf("%c", ch); break;
1371	}
1372	}
1373	break;
1374	case L_OBJECT_VAR:
1375	l_obj_print(((LObjectVar *)this)->index);
1376	break;
1377	case L_1D_ARRAY:
1378	{
1379	LArray a = (LArray )this;
1380	LObject **data = a->GetData();
1381	dprintf("#(");
1382	for (size_t j = 0; j < a->len; j++)
1383	{
1384	data[j]->Print();
1385	if (j != a->len - 1)
1386	dprintf(" ");
1387	}
1388	dprintf(")");
1389	}
1390	break;
1391	case L_COLLECTED_OBJECT:
1392	lprint_string("GC_reference->");
1393	((LRedirect *)this)->ref->Print();
1394	break;
1395	default:
1396	dprintf("Shouldn't happen\n");
1397	}
1398
1399	print_level--;
1400	if (!print_level && !current_print_file)
1401	dprintf("\n");
1402	}
1403
1404	/* PtrRef check: OK */
1405	LObject LSymbol::EvalFunction(void arg_list)
1406	{
1407	#ifdef TYPE_CHECKING
1408	int args, req_min, req_max;
1409	if (item_type(this) != L_SYMBOL)
1410	{
1411	Print();
1412	lbreak("EVAL: is not a function name (not symbol either)");
1413	exit(0);
1414	}
1415	#endif
1416
1417	LObject *fun = function;
1418	PtrRef ref2(fun);
1419	PtrRef ref3(arg_list);
1420
1421	// make sure the arguments given to the function are the correct number
1422	ltype t = item_type(fun);
1423
1424	#ifdef TYPE_CHECKING
1425	switch (t)
1426	{
1427	case L_SYS_FUNCTION:
1428	case L_C_FUNCTION:
1429	case L_C_BOOL:
1430	case L_L_FUNCTION:
1431	req_min = ((LSysFunction *)fun)->min_args;
1432	req_max = ((LSysFunction *)fun)->max_args;
1433	break;
1434	case L_USER_FUNCTION:
1435	return EvalUserFunction((LList *)arg_list);
1436	default:
1437	Print();
1438	lbreak(" is not a function name");
1439	exit(0);
1440	break;
1441	}
1442
1443	if (req_min != -1)
1444	{
1445	void *a = arg_list;
1446	for (args = 0; a; a = CDR(a))
1447	args++; // count number of parameters
1448
1449	if (args < req_min)
1450	{
1451	((LObject *)arg_list)->Print();
1452	name->Print();
1453	lbreak("\nToo few parameters to function\n");
1454	exit(0);
1455	}
1456	else if (req_max != -1 && args > req_max)
1457	{
1458	((LObject *)arg_list)->Print();
1459	name->Print();
1460	lbreak("\nToo many parameters to function\n");
1461	exit(0);
1462	}
1463	}
1464	#endif
1465
1466	#ifdef L_PROFILE
1467	time_marker start;
1468	#endif
1469
1470	LObject *ret = NULL;
1471
1472	switch (t)
1473	{
1474	case L_SYS_FUNCTION:
1475	ret = ((LSysFunction )fun)->EvalFunction((LList )arg_list);
1476	break;
1477	case L_L_FUNCTION:
1478	ret = (LObject )l_caller(((LSysFunction )fun)->fun_number, arg_list);
1479	break;
1480	case L_USER_FUNCTION:
1481	return EvalUserFunction((LList *)arg_list);
1482	case L_C_FUNCTION:
1483	case L_C_BOOL:
1484	{
1485	LList first = NULL, cur = NULL;
1486	PtrRef r1(first), r2(cur), r3(arg_list);
1487	while (arg_list)
1488	{
1489	LList *tmp = LList::Create();
1490	if (first)
1491	cur->cdr = tmp;
1492	else
1493	first = tmp;
1494	cur = tmp;
1495
1496	LObject *val = CAR(arg_list)->Eval();
1497	((LList *)cur)->car = val;
1498	arg_list = lcdr(arg_list);
1499	}
1500	if (t == L_C_FUNCTION)
1501	ret = LNumber::Create(c_caller(((LSysFunction *)fun)->fun_number, first));
1502	else if (c_caller(((LSysFunction *)fun)->fun_number, first))
1503	ret = true_symbol;
1504	else
1505	ret = NULL;
1506	break;
1507	}
1508	default:
1509	fprintf(stderr, "not a fun, shouldn't happen\n");
1510	}
1511
1512	#ifdef L_PROFILE
1513	time_marker end;
1514	time_taken += end.diff_time(&start);
1515	#endif
1516
1517	return ret;
1518	}
1519
1520	#ifdef L_PROFILE
1521	void pro_print(bFILE out, LSymbol p)
1522	{
1523	if (p)
1524	{
1525	pro_print(out, p->right);
1526	{
1527	char st[100];
1528	sprintf(st, "%20s %f\n", lstring_value(p->GetName()), p->time_taken);
1529	out->write(st, strlen(st));
1530	}
1531	pro_print(out, p->left);
1532	}
1533	}
1534
1535	void preport(char *fn)
1536	{
1537	bFILE *fp=open_file("preport.out", "wb");
1538	pro_print(fp, LSymbol::root);
1539	delete fp;
1540	}
1541	#endif
1542
1543	void mapcar(void arg_list)
1544	{
1545	PtrRef ref1(arg_list);
1546	LObject *sym = CAR(arg_list)->Eval();
1547	switch ((short)item_type(sym))
1548	{
1549	case L_SYS_FUNCTION:
1550	case L_USER_FUNCTION:
1551	case L_SYMBOL:
1552	break;
1553	default:
1554	{
1555	sym->Print();
1556	lbreak(" is not a function\n");
1557	exit(0);
1558	}
1559	}
1560	int i, stop = 0, num_args = ((LList *)CDR(arg_list))->GetLength();
1561	if (!num_args) return 0;
1562
1563	void arg_on=(void )malloc(sizeof(void )num_args);
1564	LList list_on=(LList )CDR(arg_list);
1565	long old_ptr_son=PtrRef::stack.son;
1566
1567	for (i=0; i<num_args; i++)
1568	{
1569	arg_on[i] = (LList *)CAR(list_on)->Eval();
1570	PtrRef::stack.push(&arg_on[i]);
1571
1572	list_on=(LList *)CDR(list_on);
1573	if (!arg_on[i]) stop=1;
1574	}
1575
1576	if (stop)
1577	{
1578	free(arg_on);
1579	return NULL;
1580	}
1581
1582	LList na_list=NULL, return_list=NULL, *last_return=NULL;
1583
1584	do
1585	{
1586	na_list=NULL; // create a cons list with all of the parameters for the function
1587
1588	LList *first=NULL; // save the start of the list
1589	for (i=0; !stop &&i<num_args; i++)
1590	{
1591	if (!na_list)
1592	first=na_list = LList::Create();
1593	else
1594	{
1595	na_list->cdr = (LObject *)LList::Create();
1596	na_list=(LList *)CDR(na_list);
1597	}
1598
1599
1600	if (arg_on[i])
1601	{
1602	na_list->car = (LObject *)CAR(arg_on[i]);
1603	arg_on[i]=(LList *)CDR(arg_on[i]);
1604	}
1605	else stop=1;
1606	}
1607	if (!stop)
1608	{
1609	LList *c = LList::Create();
1610	c->car = ((LSymbol *)sym)->EvalFunction(first);
1611	if (return_list)
1612	last_return->cdr=c;
1613	else
1614	return_list=c;
1615	last_return=c;
1616	}
1617	}
1618	while (!stop);
1619	PtrRef::stack.son=old_ptr_son;
1620
1621	free(arg_on);
1622	return return_list;
1623	}
1624
1625	void concatenate(void prog_list)
1626	{
1627	void *el_list=CDR(prog_list);
1628	PtrRef ref1(prog_list), ref2(el_list);
1629	void *ret=NULL;
1630	void *rtype = CAR(prog_list)->Eval();
1631
1632	long len=0; // determin the length of the resulting string
1633	if (rtype==string_symbol)
1634	{
1635	int elements = ((LList *)el_list)->GetLength(); // see how many things we need to concat
1636	if (!elements) ret = LString::Create("");
1637	else
1638	{
1639	void str_eval=(void )malloc(elementssizeof(void ));
1640	int i, old_ptr_stack_start=PtrRef::stack.son;
1641
1642	// evalaute all the strings and count their lengths
1643	for (i=0; i<elements; i++, el_list=CDR(el_list))
1644	{
1645	str_eval[i] = CAR(el_list)->Eval();
1646	PtrRef::stack.push(&str_eval[i]);
1647
1648	switch ((short)item_type(str_eval[i]))
1649	{
1650	case L_CONS_CELL :
1651	{
1652	LList char_list=(LList )str_eval[i];
1653	while (char_list)
1654	{
1655	if (item_type(CAR(char_list))==(ltype)L_CHARACTER)
1656	len++;
1657	else
1658	{
1659	((LObject *)str_eval[i])->Print();
1660	lbreak(" is not a character\n");
1661	exit(0);
1662	}
1663	char_list=(LList *)CDR(char_list);
1664	}
1665	} break;
1666	case L_STRING : len+=strlen(lstring_value(str_eval[i])); break;
1667	default :
1668	((LObject *)prog_list)->Print();
1669	lbreak("type not supported\n");
1670	exit(0);
1671	break;
1672
1673	}
1674	}
1675	LString *st = LString::Create(len+1);
1676	char *s=lstring_value(st);
1677
1678	// now add the string up into the new string
1679	for (i=0; i<elements; i++)
1680	{
1681	switch ((short)item_type(str_eval[i]))
1682	{
1683	case L_CONS_CELL :
1684	{
1685	LList char_list=(LList )str_eval[i];
1686	while (char_list)
1687	{
1688	if (item_type(CAR(char_list))==L_CHARACTER)
1689	(s++)=((LChar )CAR(char_list))->ch;
1690	char_list=(LList *)CDR(char_list);
1691	}
1692	} break;
1693	case L_STRING :
1694	{
1695	memcpy(s, lstring_value(str_eval[i]), strlen(lstring_value(str_eval[i])));
1696	s+=strlen(lstring_value(str_eval[i]));
1697	} break;
1698	default : ; // already checked for, but make compiler happy
1699	}
1700	}
1701	free(str_eval);
1702	PtrRef::stack.son=old_ptr_stack_start; // restore pointer GC stack
1703	*s=0;
1704	ret=st;
1705	}
1706	}
1707	else
1708	{
1709	((LObject *)prog_list)->Print();
1710	lbreak("concat operation not supported, try 'string\n");
1711	exit(0);
1712	}
1713	return ret;
1714	}
1715
1716
1717	void backquote_eval(void args)
1718	{
1719	if (item_type(args)!=L_CONS_CELL)
1720	return args;
1721	else if (args==NULL)
1722	return NULL;
1723	else if ((LSymbol ) (((LList )args)->car)==comma_symbol)
1724	return CAR(CDR(args))->Eval();
1725	else
1726	{
1727	void first=NULL, last=NULL, cur=NULL, tmp;
1728	PtrRef ref1(first), ref2(last), ref3(cur), ref4(args);
1729	while (args)
1730	{
1731	if (item_type(args)==L_CONS_CELL)
1732	{
1733	if (CAR(args)==comma_symbol) // dot list with a comma?
1734	{
1735	tmp = CAR(CDR(args))->Eval();
1736	((LList )last)->cdr = (LObject )tmp;
1737	args=NULL;
1738	}
1739	else
1740	{
1741	cur = LList::Create();
1742	if (first)
1743	((LList )last)->cdr = (LObject )cur;
1744	else
1745	first=cur;
1746	last=cur;
1747	tmp=backquote_eval(CAR(args));
1748	((LList )cur)->car = (LObject )tmp;
1749	args=CDR(args);
1750	}
1751	} else
1752	{
1753	tmp=backquote_eval(args);
1754	((LList )last)->cdr = (LObject )tmp;
1755	args=NULL;
1756	}
1757
1758	}
1759	return (void *)first;
1760	}
1761	return NULL; // for stupid compiler messages
1762	}
1763
1764	/* PtrRef check: OK */
1765	LObject LSysFunction::EvalFunction(LList arg_list)
1766	{
1767	LObject *ret = NULL;
1768
1769	PtrRef ref1(arg_list);
1770
1771	switch (fun_number)
1772	{
1773	case SYS_FUNC_PRINT:
1774	while (arg_list)
1775	{
1776	ret = CAR(arg_list)->Eval();
1777	arg_list = (LList *)CDR(arg_list);
1778	ret->Print();
1779	}
1780	break;
1781	case SYS_FUNC_CAR:
1782	ret = lcar(CAR(arg_list)->Eval());
1783	break;
1784	case SYS_FUNC_CDR:
1785	ret = lcdr(CAR(arg_list)->Eval());
1786	break;
1787	case SYS_FUNC_LENGTH:
1788	{
1789	LObject *v = CAR(arg_list)->Eval();
1790	switch (item_type(v))
1791	{
1792	case L_STRING:
1793	ret = LNumber::Create(strlen(lstring_value(v)));
1794	break;
1795	case L_CONS_CELL:
1796	ret = LNumber::Create(((LList *)v)->GetLength());
1797	break;
1798	default:
1799	v->Print();
1800	lbreak("length : type not supported\n");
1801	break;
1802	}
1803	break;
1804	}
1805	case SYS_FUNC_LIST:
1806	{
1807	LList cur = NULL, last = NULL, *first = NULL;
1808	PtrRef r1(cur), r2(first), r3(last);
1809	while (arg_list)
1810	{
1811	cur = LList::Create();
1812	LObject *val = CAR(arg_list)->Eval();
1813	cur->car = val;
1814	if (last)
1815	last->cdr = cur;
1816	else
1817	first = cur;
1818	last = cur;
1819	arg_list = (LList *)CDR(arg_list);
1820	}
1821	ret = first;
1822	break;
1823	}
1824	case SYS_FUNC_CONS:
1825	{
1826	LList *c = LList::Create();
1827	PtrRef r1(c);
1828	LObject *val = CAR(arg_list)->Eval();
1829	c->car = val;
1830	val = CAR(CDR(arg_list))->Eval();
1831	c->cdr = val;
1832	ret = c;
1833	break;
1834	}
1835	case SYS_FUNC_QUOTE:
1836	ret = CAR(arg_list);
1837	break;
1838	case SYS_FUNC_EQ:
1839	l_user_stack.push(CAR(arg_list)->Eval());
1840	l_user_stack.push(CAR(CDR(arg_list))->Eval());
1841	ret = (LObject *)lisp_eq(l_user_stack.pop(1), l_user_stack.pop(1));
1842	break;
1843	case SYS_FUNC_EQUAL:
1844	l_user_stack.push(CAR(arg_list)->Eval());
1845	l_user_stack.push(CAR(CDR(arg_list))->Eval());
1846	ret = (LObject *)lisp_equal(l_user_stack.pop(1), l_user_stack.pop(1));
1847	break;
1848	case SYS_FUNC_PLUS:
1849	{
1850	int32_t sum = 0;
1851	while (arg_list)
1852	{
1853	sum += lnumber_value(CAR(arg_list)->Eval());
1854	arg_list = (LList *)CDR(arg_list);
1855	}
1856	ret = LNumber::Create(sum);
1857	break;
1858	}
1859	case SYS_FUNC_TIMES:
1860	{
1861	int32_t prod;
1862	LObject *first = CAR(arg_list)->Eval();
1863	PtrRef r1(first);
1864	if (arg_list && item_type(first) == L_FIXED_POINT)
1865	{
1866	prod = 1 << 16;
1867	do
1868	{
1869	prod = (prod >> 8) * (lfixed_point_value(first) >> 8);
1870	arg_list = (LList *)CDR(arg_list);
1871	if (arg_list)
1872	first = CAR(arg_list)->Eval();
1873	} while (arg_list);
1874	ret = LFixedPoint::Create(prod);
1875	}
1876	else
1877	{
1878	prod = 1;
1879	do
1880	{
1881	prod *= lnumber_value(CAR(arg_list)->Eval());
1882	arg_list = (LList *)CDR(arg_list);
1883	if (arg_list)
1884	first = CAR(arg_list)->Eval();
1885	} while (arg_list);
1886	ret = LNumber::Create(prod);
1887	}
1888	break;
1889	}
1890	case SYS_FUNC_SLASH:
1891	{
1892	int32_t quot = 0, first = 1;
1893	while (arg_list)
1894	{
1895	LObject *i = CAR(arg_list)->Eval();
1896	if (item_type(i) != L_NUMBER)
1897	{
1898	i->Print();
1899	lbreak("/ only defined for numbers, cannot divide ");
1900	exit(0);
1901	}
1902	else if (first)
1903	{
1904	quot = ((LNumber *)i)->num;
1905	first = 0;
1906	}
1907	else
1908	quot /= ((LNumber *)i)->num;
1909	arg_list = (LList *)CDR(arg_list);
1910	}
1911	ret = LNumber::Create(quot);
1912	break;
1913	}
1914	case SYS_FUNC_MINUS:
1915	{
1916	int32_t sub = lnumber_value(CAR(arg_list)->Eval());
1917	arg_list = (LList *)CDR(arg_list);
1918	while (arg_list)
1919	{
1920	sub -= lnumber_value(CAR(arg_list)->Eval());
1921	arg_list = (LList *)CDR(arg_list);
1922	}
1923	ret = LNumber::Create(sub);
1924	break;
1925	}
1926	case SYS_FUNC_IF:
1927	if (CAR(arg_list)->Eval())
1928	ret = CAR(CDR(arg_list))->Eval();
1929	else
1930	{
1931	arg_list = (LList *)CDR(CDR(arg_list)); // check for a else part
1932	if (arg_list)
1933	ret = CAR(arg_list)->Eval();
1934	else
1935	ret = NULL;
1936	}
1937	break;
1938	case SYS_FUNC_SETQ:
1939	case SYS_FUNC_SETF:
1940	{
1941	LObject set_to = CAR(CDR(arg_list))->Eval(), i = NULL;
1942	PtrRef r1(set_to), r2(i);
1943	i = CAR(arg_list);
1944
1945	ltype x = item_type(set_to);
1946	switch (item_type(i))
1947	{
1948	case L_SYMBOL:
1949	switch (item_type(((LSymbol *)i)->value))
1950	{
1951	case L_NUMBER:
1952	if (x == L_NUMBER && ((LSymbol *)i)->value != l_undefined)
1953	((LSymbol *)i)->SetNumber(lnumber_value(set_to));
1954	else
1955	((LSymbol )i)->SetValue((LNumber )set_to);
1956	break;
1957	case L_OBJECT_VAR:
1958	l_obj_set(((LObjectVar )(((LSymbol )i)->value))->index, set_to);
1959	break;
1960	default:
1961	((LSymbol )i)->SetValue((LObject )set_to);
1962	}
1963	ret = ((LSymbol *)i)->value;
1964	break;
1965	case L_CONS_CELL: // this better be an 'aref'
1966	{
1967	#ifdef TYPE_CHECKING
1968	LObject car = ((LList )i)->car;
1969	if (car == car_symbol)
1970	{
1971	car = CAR(CDR(i))->Eval();
1972	if (!car \|\| item_type(car) != L_CONS_CELL)
1973	{
1974	car->Print();
1975	lbreak("setq car : evaled object is not a cons cell\n");
1976	exit(0);
1977	}
1978	((LList *)car)->car = set_to;
1979	}
1980	else if (car == cdr_symbol)
1981	{
1982	car = CAR(CDR(i))->Eval();
1983	if (!car \|\| item_type(car) != L_CONS_CELL)
1984	{
1985	car->Print();
1986	lbreak("setq cdr : evaled object is not a cons cell\n");
1987	exit(0);
1988	}
1989	((LList *)car)->cdr = set_to;
1990	}
1991	else if (car != aref_symbol)
1992	{
1993	lbreak("expected (aref, car, cdr, or symbol) in setq\n");
1994	exit(0);
1995	}
1996	else
1997	{
1998	#endif
1999	LArray a = (LArray )CAR(CDR(i))->Eval();
2000	PtrRef r1(a);
2001	#ifdef TYPE_CHECKING
2002	if (item_type(a) != L_1D_ARRAY)
2003	{
2004	a->Print();
2005	lbreak("is not an array (aref)\n");
2006	exit(0);
2007	}
2008	#endif
2009	int num = lnumber_value(CAR(CDR(CDR(i)))->Eval());
2010	#ifdef TYPE_CHECKING
2011	if (num >= (int)a->len \|\| num < 0)
2012	{
2013	lbreak("aref : value of bounds (%d)\n", num);
2014	exit(0);
2015	}
2016	#endif
2017	a->GetData()[num] = set_to;
2018	#ifdef TYPE_CHECKING
2019	}
2020	#endif
2021	ret = set_to;
2022	break;
2023	}
2024	default:
2025	i->Print();
2026	lbreak("setq/setf only defined for symbols and arrays now..\n");
2027	exit(0);
2028	break;
2029	}
2030	break;
2031	}
2032	case SYS_FUNC_SYMBOL_LIST:
2033	ret = NULL;
2034	break;
2035	case SYS_FUNC_ASSOC:
2036	{
2037	LObject *item = CAR(arg_list)->Eval();
2038	PtrRef r1(item);
2039	LList list = (LList )CAR(CDR(arg_list))->Eval();
2040	PtrRef r2(list);
2041	ret = (LObject *)assoc(item, list);
2042	break;
2043	}
2044	case SYS_FUNC_NOT:
2045	case SYS_FUNC_NULL:
2046	if (CAR(arg_list)->Eval() == NULL)
2047	ret = true_symbol;
2048	else
2049	ret = NULL;
2050	break;
2051	case SYS_FUNC_ACONS:
2052	{
2053	LObject *i1 = CAR(arg_list)->Eval();
2054	PtrRef r1(i1);
2055	LObject *i2 = CAR(CDR(arg_list))->Eval();
2056	PtrRef r2(i2);
2057	LList *cs = LList::Create();
2058	cs->car = i1;
2059	cs->cdr = i2;
2060	ret = cs;
2061	break;
2062	}
2063	case SYS_FUNC_PAIRLIS:
2064	{
2065	l_user_stack.push(CAR(arg_list)->Eval());
2066	arg_list = (LList *)CDR(arg_list);
2067	l_user_stack.push(CAR(arg_list)->Eval());
2068	arg_list = (LList *)CDR(arg_list);
2069	LObject *n3 = CAR(arg_list)->Eval();
2070	LObject n2 = (LObject )l_user_stack.pop(1);
2071	LObject n1 = (LObject )l_user_stack.pop(1);
2072	ret = (LObject *)pairlis(n1, n2, n3);
2073	break;
2074	}
2075	case SYS_FUNC_LET:
2076	{
2077	// make an a-list of new variable names and new values
2078	LObject *var_list = CAR(arg_list);
2079	LObject *block_list = CDR(arg_list);
2080	PtrRef r1(block_list), r2(var_list);
2081	long stack_start = l_user_stack.son;
2082
2083	while (var_list)
2084	{
2085	LObject var_name = CAR(CAR(var_list)), tmp;
2086	#ifdef TYPE_CHECKING
2087	if (item_type(var_name) != L_SYMBOL)
2088	{
2089	var_name->Print();
2090	lbreak("should be a symbol (let)\n");
2091	exit(0);
2092	}
2093	#endif
2094
2095	l_user_stack.push(((LSymbol *)var_name)->value);
2096	tmp = CAR(CDR(CAR(var_list)))->Eval();
2097	((LSymbol *)var_name)->SetValue(tmp);
2098	var_list = CDR(var_list);
2099	}
2100
2101	// now evaluate each of the blocks with the new environment and
2102	// return value from the last block
2103	while (block_list)
2104	{
2105	ret = CAR(block_list)->Eval();
2106	block_list = CDR(block_list);
2107	}
2108
2109	long cur_stack = stack_start;
2110	var_list = CAR(arg_list); // now restore the old symbol values
2111	while (var_list)
2112	{
2113	LObject *var_name = CAR(CAR(var_list));
2114	((LSymbol )var_name)->SetValue((LObject )l_user_stack.sdata[cur_stack++]);
2115	var_list = CDR(var_list);
2116	}
2117	l_user_stack.son = stack_start; // restore the stack
2118	break;
2119	}
2120	case SYS_FUNC_DEFUN:
2121	{
2122	LSymbol symbol = (LSymbol )CAR(arg_list);
2123	PtrRef r1(symbol);
2124	#ifdef TYPE_CHECKING
2125	if (item_type(symbol) != L_SYMBOL)
2126	{
2127	symbol->Print();
2128	lbreak(" is not a symbol! (DEFUN)\n");
2129	exit(0);
2130	}
2131
2132	if (item_type(arg_list) != L_CONS_CELL)
2133	{
2134	arg_list->Print();
2135	lbreak("is not a lambda list (DEFUN)\n");
2136	exit(0);
2137	}
2138	#endif
2139	LObject *block_list = CDR(CDR(arg_list));
2140
2141	LUserFunction ufun = new_lisp_user_function((LList )lcar(lcdr(arg_list)), (LList *)block_list);
2142	symbol->SetFunction(ufun);
2143	ret = symbol;
2144	break;
2145	}
2146	case SYS_FUNC_ATOM:
2147	ret = (LObject *)lisp_atom(CAR(arg_list)->Eval());
2148	break;
2149	case SYS_FUNC_AND:
2150	{
2151	LObject *l = arg_list;
2152	PtrRef r1(l);
2153	ret = true_symbol;
2154	while (l)
2155	{
2156	if (!CAR(l)->Eval())
2157	{
2158	ret = NULL;
2159	l = NULL; // short-circuit
2160	}
2161	else
2162	l = CDR(l);
2163	}
2164	break;
2165	}
2166	case SYS_FUNC_OR:
2167	{
2168	LObject *l = arg_list;
2169	PtrRef r1(l);
2170	ret = NULL;
2171	while (l)
2172	{
2173	if (CAR(l)->Eval())
2174	{
2175	ret = true_symbol;
2176	l = NULL; // short-circuit
2177	}
2178	else
2179	l = CDR(l);
2180	}
2181	break;
2182	}
2183	case SYS_FUNC_PROGN:
2184	ret = (LObject *)eval_block(arg_list);
2185	break;
2186	case SYS_FUNC_CONCATENATE:
2187	ret = (LObject *)concatenate(arg_list);
2188	break;
2189	case SYS_FUNC_CHAR_CODE:
2190	{
2191	LObject *i = CAR(arg_list)->Eval();
2192	PtrRef r1(i);
2193	ret = NULL;
2194	switch (item_type(i))
2195	{
2196	case L_CHARACTER:
2197	ret = LNumber::Create(((LChar *)i)->ch);
2198	break;
2199	case L_STRING:
2200	ret = LNumber::Create(*lstring_value(i));
2201	break;
2202	default:
2203	i->Print();
2204	lbreak(" is not character type\n");
2205	exit(0);
2206	break;
2207	}
2208	break;
2209	}
2210	case SYS_FUNC_CODE_CHAR:
2211	{
2212	LObject *i = CAR(arg_list)->Eval();
2213	PtrRef r1(i);
2214	if (item_type(i) != L_NUMBER)
2215	{
2216	i->Print();
2217	lbreak(" is not number type\n");
2218	exit(0);
2219	}
2220	ret = LChar::Create(((LNumber *)i)->num);
2221	break;
2222	}
2223	case SYS_FUNC_COND:
2224	{
2225	LList block_list = (LList )CAR(arg_list);
2226	PtrRef r1(block_list);
2227	ret = NULL;
2228	PtrRef r2(ret); // Required to protect from the last Eval call
2229	while (block_list)
2230	{
2231	if (lcar(CAR(block_list))->Eval())
2232	ret = CAR(CDR(CAR(block_list)))->Eval();
2233	block_list = (LList *)CDR(block_list);
2234	}
2235	break;
2236	}
2237	case SYS_FUNC_SELECT:
2238	{
2239	LObject *selector = CAR(arg_list)->Eval();
2240	LObject *sel = CDR(arg_list);
2241	PtrRef r1(selector), r2(sel);
2242	ret = NULL;
2243	PtrRef r3(ret); // Required to protect from the last Eval call
2244	while (sel)
2245	{
2246	if (lisp_equal(selector, CAR(CAR(sel))->Eval()))
2247	{
2248	sel = CDR(CAR(sel));
2249	while (sel)
2250	{
2251	ret = CAR(sel)->Eval();
2252	sel = CDR(sel);
2253	}
2254	}
2255	else
2256	sel = CDR(sel);
2257	}
2258	break;
2259	}
2260	case SYS_FUNC_FUNCTION:
2261	ret = ((LSymbol *)CAR(arg_list)->Eval())->GetFunction();
2262	break;
2263	case SYS_FUNC_MAPCAR:
2264	ret = (LObject *)mapcar(arg_list);
2265	break;
2266	case SYS_FUNC_FUNCALL:
2267	{
2268	LSymbol n1 = (LSymbol )CAR(arg_list)->Eval();
2269	ret = n1->EvalFunction(CDR(arg_list));
2270	break;
2271	}
2272	case SYS_FUNC_GT:
2273	{
2274	int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
2275	int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
2276	ret = n1 > n2 ? true_symbol : NULL;
2277	break;
2278	}
2279	case SYS_FUNC_LT:
2280	{
2281	int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
2282	int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
2283	ret = n1 < n2 ? true_symbol : NULL;
2284	break;
2285	}
2286	case SYS_FUNC_GE:
2287	{
2288	int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
2289	int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
2290	ret = n1 >= n2 ? true_symbol : NULL;
2291	break;
2292	}
2293	case SYS_FUNC_LE:
2294	{
2295	int32_t n1 = lnumber_value(CAR(arg_list)->Eval());
2296	int32_t n2 = lnumber_value(CAR(CDR(arg_list))->Eval());
2297	ret = n1 <= n2 ? true_symbol : NULL;
2298	break;
2299	}
2300	case SYS_FUNC_TMP_SPACE:
2301	tmp_space();
2302	ret = true_symbol;
2303	break;
2304	case SYS_FUNC_PERM_SPACE:
2305	perm_space();
2306	ret = true_symbol;
2307	break;
2308	case SYS_FUNC_SYMBOL_NAME:
2309	{
2310	LSymbol symb = (LSymbol )CAR(arg_list)->Eval();
2311	#ifdef TYPE_CHECKING
2312	if (item_type(symb) != L_SYMBOL)
2313	{
2314	symb->Print();
2315	lbreak(" is not a symbol (symbol-name)\n");
2316	exit(0);
2317	}
2318	#endif
2319	ret = symb->name;
2320	break;
2321	}
2322	case SYS_FUNC_TRACE:
2323	trace_level++;
2324	if (arg_list)
2325	trace_print_level = lnumber_value(CAR(arg_list)->Eval());
2326	ret = true_symbol;
2327	break;
2328	case SYS_FUNC_UNTRACE:
2329	if (trace_level > 0)
2330	{
2331	trace_level--;
2332	ret = true_symbol;
2333	}
2334	else
2335	ret = NULL;
2336	break;
2337	case SYS_FUNC_DIGSTR:
2338	{
2339	char tmp[50], *tp;
2340	int32_t num = lnumber_value(CAR(arg_list)->Eval());
2341	int32_t dig = lnumber_value(CAR(CDR(arg_list))->Eval());
2342	tp = tmp + 49;
2343	*(tp--) = 0;
2344	while (num)
2345	{
2346	*(tp--) = '0' + (num % 10);
2347	num /= 10;
2348	dig--;
2349	}
2350	while (dig--)
2351	*(tp--) = '0';
2352	ret = LString::Create(tp + 1);
2353	break;
2354	}
2355	case SYS_FUNC_LOCAL_LOAD:
2356	case SYS_FUNC_LOAD:
2357	case SYS_FUNC_COMPILE_FILE:
2358	{
2359	LObject *fn = CAR(arg_list)->Eval();
2360	PtrRef r1(fn);
2361	char *st = lstring_value(fn);
2362	bFILE *fp;
2363	if (fun_number == SYS_FUNC_LOCAL_LOAD)
2364	{
2365	// A special test for gamma.lsp
2366	if (strcmp(st, "gamma.lsp") == 0)
2367	{
2368	char *gammapath;
2369	gammapath = (char *)malloc(strlen(get_save_filename_prefix()) + 9 + 1);
2370	sprintf(gammapath, "%sgamma.lsp", get_save_filename_prefix());
2371	fp = new jFILE(gammapath, "rb");
2372	free(gammapath);
2373	}
2374	else
2375	fp = new jFILE(st, "rb");
2376	}
2377	else
2378	fp = open_file(st, "rb");
2379
2380	if (fp->open_failure())
2381	{
2382	delete fp;
2383	if (DEFINEDP(((LSymbol *)load_warning)->GetValue())
2384	&& ((LSymbol *)load_warning)->GetValue())
2385	dprintf("Warning : file %s does not exist\n", st);
2386	ret = NULL;
2387	}
2388	else
2389	{
2390	size_t l = fp->file_size();
2391	char s = (char )malloc(l + 1);
2392	if (!s)
2393	{
2394	printf("Malloc error in load_script\n");
2395	exit(0);
2396	}
2397
2398	fp->read(s, l);
2399	s[l] = 0;
2400	delete fp;
2401	char const *cs = s;
2402	#ifndef NO_LIBS
2403	char msg[100];
2404	sprintf(msg, "(load \"%s\")", st);
2405	if (stat_man)
2406	stat_man->push(msg, NULL);
2407	crc_manager.get_filenumber(st); // make sure this file gets crc'ed
2408	#endif
2409	LObject *compiled_form = NULL;
2410	PtrRef r11(compiled_form);
2411	while (!end_of_program(cs)) // see if there is anything left to compile and run
2412	{
2413	#ifndef NO_LIBS
2414	if (stat_man)
2415	stat_man->update((cs - s) * 100 / l);
2416	#endif
2417	void *m = mark_heap(TMP_SPACE);
2418	compiled_form = LObject::Compile(cs);
2419	compiled_form->Eval();
2420	compiled_form = NULL;
2421	restore_heap(m, TMP_SPACE);
2422	}
2423	#ifndef NO_LIBS
2424	if (stat_man)
2425	{
2426	stat_man->update(100);
2427	stat_man->pop();
2428	}
2429	#endif
2430	free(s);
2431	ret = fn;
2432	}
2433	break;
2434	}
2435	case SYS_FUNC_ABS:
2436	ret = LNumber::Create(abs(lnumber_value(CAR(arg_list)->Eval())));
2437	break;
2438	case SYS_FUNC_MIN:
2439	{
2440	int32_t x = lnumber_value(CAR(arg_list)->Eval());
2441	int32_t y = lnumber_value(CAR(CDR(arg_list))->Eval());
2442	ret = LNumber::Create(x < y ? x : y);
2443	break;
2444	}
2445	case SYS_FUNC_MAX:
2446	{
2447	int32_t x = lnumber_value(CAR(arg_list)->Eval());
2448	int32_t y = lnumber_value(CAR(CDR(arg_list))->Eval());
2449	ret = LNumber::Create(x > y ? x : y);
2450	break;
2451	}
2452	case SYS_FUNC_BACKQUOTE:
2453	ret = (LObject *)backquote_eval(CAR(arg_list));
2454	break;
2455	case SYS_FUNC_COMMA:
2456	arg_list->Print();
2457	lbreak("comma is illegal outside of backquote\n");
2458	exit(0);
2459	break;
2460	case SYS_FUNC_NTH:
2461	{
2462	int32_t x = lnumber_value(CAR(arg_list)->Eval());
2463	ret = (LObject *)nth(x, CAR(CDR(arg_list))->Eval());
2464	break;
2465	}
2466	case SYS_FUNC_RESIZE_TMP:
2467	resize_tmp(lnumber_value(CAR(arg_list)->Eval()));
2468	break;
2469	case SYS_FUNC_RESIZE_PERM:
2470	resize_perm(lnumber_value(CAR(arg_list)->Eval()));
2471	break;
2472	case SYS_FUNC_COS:
2473	ret = LFixedPoint::Create(lisp_cos(lnumber_value(CAR(arg_list)->Eval())));
2474	break;
2475	case SYS_FUNC_SIN:
2476	ret = LFixedPoint::Create(lisp_sin(lnumber_value(CAR(arg_list)->Eval())));
2477	break;
2478	case SYS_FUNC_ATAN2:
2479	{
2480	int32_t y = (lnumber_value(CAR(arg_list)->Eval()));
2481	int32_t x = (lnumber_value(CAR(CDR(arg_list))->Eval()));
2482	ret = LNumber::Create(lisp_atan2(y, x));
2483	break;
2484	}
2485	case SYS_FUNC_ENUM:
2486	{
2487	int sp = current_space;
2488	current_space = PERM_SPACE;
2489	int32_t x = 0;
2490	while (arg_list)
2491	{
2492	LObject *sym = CAR(arg_list)->Eval();
2493	PtrRef r1(sym);
2494	switch (item_type(sym))
2495	{
2496	case L_SYMBOL:
2497	{
2498	LObject *tmp = LNumber::Create(x);
2499	((LSymbol *)sym)->value = tmp;
2500	break;
2501	}
2502	case L_CONS_CELL:
2503	{
2504	LObject *s = CAR(sym)->Eval();
2505	PtrRef r1(s);
2506	#ifdef TYPE_CHECKING
2507	if (item_type(s) != L_SYMBOL)
2508	{
2509	arg_list->Print();
2510	lbreak("expecting (symbol value) for enum\n");
2511	exit(0);
2512	}
2513	#endif
2514	x = lnumber_value(CAR(CDR(sym))->Eval());
2515	LObject *tmp = LNumber::Create(x);
2516	((LSymbol *)sym)->value = tmp;
2517	break;
2518	}
2519	default:
2520	arg_list->Print();
2521	lbreak("expecting symbol or (symbol value) in enum\n");
2522	exit(0);
2523	}
2524	arg_list = (LList *)CDR(arg_list);
2525	x++;
2526	}
2527	current_space = sp;
2528	break;
2529	}
2530	case SYS_FUNC_QUIT:
2531	exit(0);
2532	break;
2533	case SYS_FUNC_EVAL:
2534	ret = CAR(arg_list)->Eval()->Eval();
2535	break;
2536	case SYS_FUNC_BREAK:
2537	lbreak("User break");
2538	break;
2539	case SYS_FUNC_MOD:
2540	{
2541	int32_t x = lnumber_value(CAR(arg_list)->Eval());
2542	int32_t y = lnumber_value(CAR(CDR(arg_list))->Eval());
2543	if (y == 0)
2544	{
2545	lbreak("mod: division by zero\n");
2546	y = 1;
2547	}
2548	ret = LNumber::Create(x % y);
2549	break;
2550	}
2551	#if 0
2552	case SYS_FUNC_WRITE_PROFILE:
2553	{
2554	char *fn = lstring_value(CAR(arg_list)->Eval());
2555	FILE *fp = fopen(fn, "wb");
2556	if (!fp)
2557	lbreak("could not open %s for writing", fn);
2558	else
2559	{
2560	for (void *s = symbol_list; s; s = CDR(s))
2561	fprintf(fp, "%8d %s\n", ((LSymbol *)(CAR(s)))->call_counter,
2562	lstring_value(((LSymbol *)(CAR(s)))->name));
2563	fclose(fp);
2564	}
2565	break;
2566	}
2567	#endif
2568	case SYS_FUNC_FOR:
2569	{
2570	LSymbol bind_var = (LSymbol )CAR(arg_list);
2571	PtrRef r1(bind_var);
2572	if (item_type(bind_var) != L_SYMBOL)
2573	{
2574	lbreak("expecting for iterator to be a symbol\n");
2575	exit(1);
2576	}
2577	arg_list = (LList *)CDR(arg_list);
2578
2579	if (CAR(arg_list) != in_symbol)
2580	{
2581	lbreak("expecting in after 'for iterator'\n");
2582	exit(1);
2583	}
2584	arg_list = (LList *)CDR(arg_list);
2585
2586	LObject *ilist = CAR(arg_list)->Eval();
2587	PtrRef r2(ilist);
2588	arg_list = (LList *)CDR(arg_list);
2589
2590	if (CAR(arg_list) != do_symbol)
2591	{
2592	lbreak("expecting do after 'for iterator in list'\n");
2593	exit(1);
2594	}
2595	arg_list = (LList *)CDR(arg_list);
2596
2597	LObject *block = NULL;
2598	PtrRef r3(block);
2599	PtrRef r4(ret); // Required to protect from the last SetValue call
2600	l_user_stack.push(bind_var->GetValue()); // save old symbol value
2601	while (ilist)
2602	{
2603	bind_var->SetValue((LObject *)CAR(ilist));
2604	for (block = arg_list; block; block = CDR(block))
2605	ret = CAR(block)->Eval();
2606	ilist = CDR(ilist);
2607	}
2608	bind_var->SetValue((LObject *)l_user_stack.pop(1)); // restore value
2609	break;
2610	}
2611	case SYS_FUNC_OPEN_FILE:
2612	{
2613	LObject *str1 = CAR(arg_list)->Eval();
2614	PtrRef r1(str1);
2615	LObject *str2 = CAR(CDR(arg_list))->Eval();
2616
2617	bFILE *old_file = current_print_file;
2618	current_print_file = open_file(lstring_value(str1),
2619	lstring_value(str2));
2620
2621	if (!current_print_file->open_failure())
2622	{
2623	while (arg_list)
2624	{
2625	ret = CAR(arg_list)->Eval();
2626	arg_list = (LList *)CDR(arg_list);
2627	}
2628	}
2629	delete current_print_file;
2630	current_print_file = old_file;
2631	break;
2632	}
2633	case SYS_FUNC_BIT_AND:
2634	{
2635	int32_t first = lnumber_value(CAR(arg_list)->Eval());
2636	arg_list = (LList *)CDR(arg_list);
2637	while (arg_list)
2638	{
2639	first &= lnumber_value(CAR(arg_list)->Eval());
2640	arg_list = (LList *)CDR(arg_list);
2641	}
2642	ret = LNumber::Create(first);
2643	break;
2644	}
2645	case SYS_FUNC_BIT_OR:
2646	{
2647	int32_t first = lnumber_value(CAR(arg_list)->Eval());
2648	arg_list = (LList *)CDR(arg_list);
2649	while (arg_list)
2650	{
2651	first \|= lnumber_value(CAR(arg_list)->Eval());
2652	arg_list = (LList *)CDR(arg_list);
2653	}
2654	ret = LNumber::Create(first);
2655	break;
2656	}
2657	case SYS_FUNC_BIT_XOR:
2658	{
2659	int32_t first = lnumber_value(CAR(arg_list)->Eval());
2660	arg_list = (LList *)CDR(arg_list);
2661	while (arg_list)
2662	{
2663	first ^= lnumber_value(CAR(arg_list)->Eval());
2664	arg_list = (LList *)CDR(arg_list);
2665	}
2666	ret = LNumber::Create(first);
2667	break;
2668	}
2669	case SYS_FUNC_MAKE_ARRAY:
2670	{
2671	int32_t l = lnumber_value(CAR(arg_list)->Eval());
2672	if (l >= (2 << 16) \|\| l <= 0)
2673	{
2674	lbreak("bad array size %d\n", l);
2675	exit(0);
2676	}
2677	ret = LArray::Create(l, CDR(arg_list));
2678	break;
2679	}
2680	case SYS_FUNC_AREF:
2681	{
2682	int32_t x = lnumber_value(CAR(CDR(arg_list))->Eval());
2683	ret = ((LArray *)CAR(arg_list)->Eval())->Get(x);
2684	break;
2685	}
2686	case SYS_FUNC_IF_1PROGN:
2687	if (CAR(arg_list)->Eval())
2688	ret = (LObject *)eval_block(CAR(CDR(arg_list)));
2689	else
2690	ret = CAR(CDR(CDR(arg_list)))->Eval();
2691	break;
2692	case SYS_FUNC_IF_2PROGN:
2693	if (CAR(arg_list)->Eval())
2694	ret = CAR(CDR(arg_list))->Eval();
2695	else
2696	ret = (LObject *)eval_block(CAR(CDR(CDR(arg_list))));
2697
2698	break;
2699	case SYS_FUNC_IF_12PROGN:
2700	if (CAR(arg_list)->Eval())
2701	ret = (LObject *)eval_block(CAR(CDR(arg_list)));
2702	else
2703	ret = (LObject *)eval_block(CAR(CDR(CDR(arg_list))));
2704	break;
2705	case SYS_FUNC_EQ0:
2706	{
2707	LObject *v = CAR(arg_list)->Eval();
2708	if (item_type(v) != L_NUMBER \|\| (((LNumber *)v)->num != 0))
2709	ret = NULL;
2710	else
2711	ret = true_symbol;
2712	break;
2713	}
2714	case SYS_FUNC_PREPORT:
2715	{
2716	#ifdef L_PROFILE
2717	char *s = lstring_value(CAR(arg_list)->Eval());
2718	preport(s);
2719	#endif
2720	break;
2721	}
2722	case SYS_FUNC_SEARCH:
2723	{
2724	LObject *arg1 = CAR(arg_list)->Eval();
2725	PtrRef r1(arg1); // protect this reference
2726	arg_list = (LList *)CDR(arg_list);
2727	char *haystack = lstring_value(CAR(arg_list)->Eval());
2728	char *needle = lstring_value(arg1);
2729
2730	char *find = strstr(haystack, needle);
2731	ret = find ? LNumber::Create(find - haystack) : NULL;
2732	break;
2733	}
2734	case SYS_FUNC_ELT:
2735	{
2736	LObject *arg1 = CAR(arg_list)->Eval();
2737	PtrRef r1(arg1); // protect this reference
2738	arg_list = (LList *)CDR(arg_list);
2739	int32_t x = lnumber_value(CAR(arg_list)->Eval());
2740	char *st = lstring_value(arg1);
2741	if (x < 0 \|\| x >= (int32_t)strlen(st))
2742	{
2743	lbreak("elt: out of range of string\n");
2744	ret = NULL;
2745	}
2746	else
2747	ret = LChar::Create(st[x]);
2748	break;
2749	}
2750	case SYS_FUNC_LISTP:
2751	{
2752	LObject *tmp = CAR(arg_list)->Eval();
2753	ltype t = item_type(tmp);
2754	ret = (t == L_CONS_CELL) ? true_symbol : NULL;
2755	break;
2756	}
2757	case SYS_FUNC_NUMBERP:
2758	{
2759	LObject *tmp = CAR(arg_list)->Eval();
2760	ltype t = item_type(tmp);
2761	ret = (t == L_NUMBER \|\| t == L_FIXED_POINT) ? true_symbol : NULL;
2762	break;
2763	}
2764	case SYS_FUNC_DO:
2765	{
2766	LObject *init_var = CAR(arg_list);
2767	PtrRef r1(init_var);
2768	int ustack_start = l_user_stack.son; // restore stack at end
2769	LSymbol *sym = NULL;
2770	PtrRef r2(sym);
2771
2772	// check to make sure iter vars are symbol and push old values
2773	for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
2774	{
2775	sym = (LSymbol *)CAR(CAR(init_var));
2776	if (item_type(sym) != L_SYMBOL)
2777	{
2778	lbreak("expecting symbol name for iteration var\n");
2779	exit(0);
2780	}
2781	l_user_stack.push(sym->GetValue());
2782	}
2783
2784	void **do_evaled = l_user_stack.sdata + l_user_stack.son;
2785	// push all of the init forms, so we can set the symbol
2786	for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
2787	l_user_stack.push(CAR(CDR(CAR((init_var))))->Eval());
2788
2789	// now set all the symbols
2790	for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
2791	{
2792	sym = (LSymbol *)CAR(CAR(init_var));
2793	sym->SetValue((LObject )do_evaled);
2794	do_evaled++;
2795	}
2796
2797	for (int i = 0; !i; ) // set i to 1 when terminate conditions are met
2798	{
2799	i = CAR(CAR(CDR(arg_list)))->Eval() != NULL;
2800	if (!i)
2801	{
2802	eval_block(CDR(CDR(arg_list)));
2803	for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
2804	CAR(CDR(CDR(CAR(init_var))))->Eval();
2805	}
2806	}
2807
2808	ret = CAR(CDR(CAR(CDR(arg_list))))->Eval();
2809
2810	// restore old values for symbols
2811	do_evaled = l_user_stack.sdata + ustack_start;
2812	for (init_var = CAR(arg_list); init_var; init_var = CDR(init_var))
2813	{
2814	sym = (LSymbol *)CAR(CAR(init_var));
2815	sym->SetValue((LObject )do_evaled);
2816	do_evaled++;
2817	}
2818
2819	l_user_stack.son = ustack_start;
2820	break;
2821	}
2822	case SYS_FUNC_GC:
2823	collect_space(current_space, 0);
2824	break;
2825	case SYS_FUNC_SCHAR:
2826	{
2827	char *s = lstring_value(CAR(arg_list)->Eval());
2828	arg_list = (LList *)CDR(arg_list);
2829	int32_t x = lnumber_value(CAR(arg_list)->Eval());
2830
2831	if (x < 0 \|\| x >= (int32_t)strlen(s))
2832	{
2833	lbreak("SCHAR: index %d out of bounds\n", x);
2834	exit(0);
2835	}
2836	ret = LChar::Create(s[x]);
2837	break;
2838	}
2839	case SYS_FUNC_SYMBOLP:
2840	{
2841	LObject *tmp = CAR(arg_list)->Eval();
2842	ret = (item_type(tmp) == L_SYMBOL) ? true_symbol : NULL;
2843	break;
2844	}
2845	case SYS_FUNC_NUM2STR:
2846	{
2847	char str[20];
2848	sprintf(str, "%ld", (long int)lnumber_value(CAR(arg_list)->Eval()));
2849	ret = LString::Create(str);
2850	break;
2851	}
2852	case SYS_FUNC_NCONC:
2853	{
2854	LObject *l1 = CAR(arg_list)->Eval();
2855	PtrRef r1(l1);
2856	arg_list = (LList *)CDR(arg_list);
2857	LObject first = l1, next;
2858	PtrRef r2(first);
2859
2860	if (!l1)
2861	{
2862	l1 = first = CAR(arg_list)->Eval();
2863	arg_list = (LList *)CDR(arg_list);
2864	}
2865
2866	if (item_type(l1) != L_CONS_CELL)
2867	{
2868	l1->Print();
2869	lbreak("first arg should be a list\n");
2870	}
2871
2872	do
2873	{
2874	next = l1;
2875	while (next)
2876	{
2877	l1 = next;
2878	next = lcdr(next);
2879	}
2880	LObject *tmp = CAR(arg_list)->Eval();
2881	((LList *)l1)->cdr = tmp;
2882	arg_list = (LList *)CDR(arg_list);
2883	} while (arg_list);
2884	ret = first;
2885	break;
2886	}
2887	case SYS_FUNC_FIRST:
2888	ret = CAR(CAR(arg_list)->Eval());
2889	break;
2890	case SYS_FUNC_SECOND:
2891	ret = CAR(CDR(CAR(arg_list)->Eval()));
2892	break;
2893	case SYS_FUNC_THIRD:
2894	ret = CAR(CDR(CDR(CAR(arg_list)->Eval())));
2895	break;
2896	case SYS_FUNC_FOURTH:
2897	ret = CAR(CDR(CDR(CDR(CAR(arg_list)->Eval()))));
2898	break;
2899	case SYS_FUNC_FIFTH:
2900	ret = CAR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))));
2901	break;
2902	case SYS_FUNC_SIXTH:
2903	ret = CAR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))));
2904	break;
2905	case SYS_FUNC_SEVENTH:
2906	ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))));
2907	break;
2908	case SYS_FUNC_EIGHTH:
2909	ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))))));
2910	break;
2911	case SYS_FUNC_NINTH:
2912	ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval())))))))));
2913	break;
2914	case SYS_FUNC_TENTH:
2915	ret = CAR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CDR(CAR(arg_list)->Eval()))))))))));
2916	break;
2917	case SYS_FUNC_SUBSTR:
2918	{
2919	int32_t x1 = lnumber_value(CAR(arg_list)->Eval());
2920	int32_t x2 = lnumber_value(CAR(CDR(arg_list))->Eval());
2921	LObject *st = CAR(CAR(CDR(arg_list)))->Eval();
2922	PtrRef r1(st);
2923
2924	if (x1 < 0 \|\| x1 > x2 \|\| x2 >= (int32_t)strlen(lstring_value(st)))
2925	lbreak("substr: bad x1 or x2 value");
2926
2927	LString *s = LString::Create(x2 - x1 + 2);
2928	if (x2 - x1)
2929	memcpy(lstring_value(s), lstring_value(st) + x1, x2 - x1 + 1);
2930
2931	lstring_value(s)[x2 - x1 + 1] = 0;
2932	ret = s;
2933	break;
2934	}
2935	case 99:
2936	{
2937	LObject r = NULL, rstart = NULL;
2938	PtrRef r1(r), r2(rstart);
2939	while (arg_list)
2940	{
2941	LObject *q = CAR(arg_list)->Eval();
2942	if (!rstart)
2943	rstart = q;
2944	while (r && CDR(r))
2945	r = CDR(r);
2946	CDR(r) = q;
2947	arg_list = (LList *)CDR(arg_list);
2948	}
2949	ret = rstart;
2950	break;
2951	}
2952	default:
2953	dprintf("Undefined system function number %d\n", fun_number);
2954	break;
2955	}
2956
2957	return ret;
2958	}
2959
2960	void tmp_space()
2961	{
2962	current_space = TMP_SPACE;
2963	}
2964
2965	void perm_space()
2966	{
2967	current_space = PERM_SPACE;
2968	}
2969
2970	void use_user_space(void *addr, long size)
2971	{
2972	current_space = USER_SPACE;
2973	free_space[USER_SPACE] = space[USER_SPACE] = (uint8_t *)addr;
2974	space_size[USER_SPACE] = size;
2975	}
2976
2977	/* PtrRef check: OK */
2978	LObject LSymbol::EvalUserFunction(LList arg_list)
2979	{
2980	LObject *ret = NULL;
2981	PtrRef ref1(ret);
2982
2983	#ifdef TYPE_CHECKING
2984	if (item_type(this) != L_SYMBOL)
2985	{
2986	Print();
2987	lbreak("EVAL : is not a function name (not symbol either)");
2988	exit(0);
2989	}
2990	#endif
2991	#ifdef L_PROFILE
2992	time_marker start;
2993	#endif
2994
2995	LUserFunction fun = (LUserFunction )function;
2996
2997	#ifdef TYPE_CHECKING
2998	if (item_type(fun) != L_USER_FUNCTION)
2999	{
3000	Print();
3001	lbreak("is not a user defined function\n");
3002	}
3003	#endif
3004
3005	LList *fun_arg_list = fun->arg_list;
3006	LList *block_list = fun->block_list;
3007	PtrRef r9(block_list), r10(fun_arg_list);
3008
3009	// mark the start start, so we can restore when done
3010	long stack_start = l_user_stack.son;
3011
3012	// first push all of the old symbol values
3013	LObject *f_arg = NULL;
3014	PtrRef r18(f_arg);
3015	PtrRef r19(arg_list);
3016
3017	for (f_arg = fun_arg_list; f_arg; f_arg = CDR(f_arg))
3018	{
3019	LSymbol s = (LSymbol )CAR(f_arg);
3020	l_user_stack.push(s->value);
3021	}
3022
3023	// open block so that local vars aren't saved on the stack
3024	{
3025	int new_start = l_user_stack.son;
3026	int i = new_start;
3027	// now push all the values we wish to gather
3028	for (f_arg = fun_arg_list; f_arg; f_arg = CDR(f_arg))
3029	{
3030	if (!arg_list)
3031	{
3032	Print();
3033	lbreak("too few parameter to function\n");
3034	exit(0);
3035	}
3036	l_user_stack.push(CAR(arg_list)->Eval());
3037	arg_list = (LList *)CDR(arg_list);
3038	}
3039
3040	// now store all the values and put them into the symbols
3041	for (f_arg = fun_arg_list; f_arg; f_arg = CDR(f_arg))
3042	((LSymbol )CAR(f_arg))->SetValue((LObject )l_user_stack.sdata[i++]);
3043
3044	l_user_stack.son = new_start;
3045	}
3046
3047	if (f_arg)
3048	{
3049	Print();
3050	lbreak("too many parameter to function\n");
3051	exit(0);
3052	}
3053
3054	// now evaluate the function block
3055	while (block_list)
3056	{
3057	ret = CAR(block_list)->Eval();
3058	block_list = (LList *)CDR(block_list);
3059	}
3060
3061	long cur_stack = stack_start;
3062	for (f_arg = fun_arg_list; f_arg; f_arg = CDR(f_arg))
3063	((LSymbol )CAR(f_arg))->SetValue((LObject )l_user_stack.sdata[cur_stack++]);
3064
3065	l_user_stack.son = stack_start;
3066
3067	#ifdef L_PROFILE
3068	time_marker end;
3069	sym->time_taken += end.diff_time(&start);
3070	#endif
3071
3072	return ret;
3073	}
3074
3075	/* PtrRef check: OK */
3076	LObject *LObject::Eval()
3077	{
3078	PtrRef ref1(this);
3079
3080	int tstart = trace_level;
3081
3082	if (trace_level)
3083	{
3084	if (trace_level <= trace_print_level)
3085	{
3086	dprintf("%d (%d, %d, %d) TRACE : ", trace_level,
3087	get_free_size(PERM_SPACE), get_free_size(TMP_SPACE),
3088	PtrRef::stack.son);
3089	Print();
3090	dprintf("\n");
3091	}
3092	trace_level++;
3093	}
3094
3095	LObject *ret = NULL;
3096
3097	if (this)
3098	{
3099	switch (item_type(this))
3100	{
3101	case L_BAD_CELL:
3102	lbreak("error: eval on a bad cell\n");
3103	exit(0);
3104	break;
3105	case L_CHARACTER:
3106	case L_STRING:
3107	case L_NUMBER:
3108	case L_POINTER:
3109	case L_FIXED_POINT:
3110	ret = this;
3111	break;
3112	case L_SYMBOL:
3113	if (this == true_symbol)
3114	ret = this;
3115	else
3116	{
3117	ret = ((LSymbol *)this)->GetValue();
3118	if (item_type(ret) == L_OBJECT_VAR)
3119	ret = (LObject )l_obj_get(((LObjectVar )ret)->index);
3120	}
3121	break;
3122	case L_CONS_CELL:
3123	ret = ((LSymbol *)CAR(this))->EvalFunction(CDR(this));
3124	break;
3125	default :
3126	fprintf(stderr, "shouldn't happen\n");
3127	break;
3128	}
3129	}
3130
3131	if (tstart)
3132	{
3133	trace_level--;
3134	if (trace_level <= trace_print_level)
3135	dprintf("%d (%d, %d, %d) TRACE ==> ", trace_level,
3136	get_free_size(PERM_SPACE), get_free_size(TMP_SPACE),
3137	PtrRef::stack.son);
3138	ret->Print();
3139	dprintf("\n");
3140	}
3141
3142	/* l_user_stack.push(ret);
3143	collect_space(PERM_SPACE);
3144	ret=l_user_stack.pop(1); */
3145
3146	return ret;
3147	}
3148
3149	void resize_perm(size_t new_size)
3150	{
3151	if (new_size<((char )free_space[PERM_SPACE]-(char )space[PERM_SPACE]))
3152	{
3153	lbreak("resize perm : %d is to small to hold current heap\n", new_size);
3154	exit(0);
3155	} else if (new_size>space_size[PERM_SPACE])
3156	{
3157	lbreak("Only smaller resizes allowed for now.\n");
3158	exit(0);
3159	} else
3160	dprintf("doesn't work yet!\n");
3161	}
3162
3163	void resize_tmp(size_t new_size)
3164	{
3165	if (new_size<((char )free_space[TMP_SPACE]-(char )space[TMP_SPACE]))
3166	{
3167	lbreak("resize perm : %d is to small to hold current heap\n", new_size);
3168	exit(0);
3169	} else if (new_size>space_size[TMP_SPACE])
3170	{
3171	printf("Only smaller resizes allowed for now.\n");
3172	exit(0);
3173	} else if (free_space[TMP_SPACE]==space[TMP_SPACE])
3174	{
3175	free_space[TMP_SPACE] = space[TMP_SPACE] = (uint8_t *)realloc(space[TMP_SPACE], new_size);
3176	space_size[TMP_SPACE] = new_size;
3177	dprintf("Lisp : tmp space resized to %d\n", new_size);
3178	} else dprintf("Lisp :tmp not empty, cannot resize\n");
3179	}
3180
3181	void l_comp_init();
3182	void lisp_init(long perm_size, long tmp_size)
3183	{
3184	unsigned int i;
3185	LSymbol::root = NULL;
3186	total_user_functions = 0;
3187
3188	free_space[0] = space[0] = (uint8_t *)malloc(perm_size);
3189	space_size[0] = perm_size;
3190
3191	free_space[1] = space[1] = (uint8_t *)malloc(tmp_size);
3192	space_size[1] = tmp_size;
3193
3194
3195	current_space=PERM_SPACE;
3196
3197
3198	l_comp_init();
3199	for(i = 0; i < sizeof(sys_funcs) / sizeof(*sys_funcs); i++)
3200	add_sys_function(sys_funcs[i].name,
3201	sys_funcs[i].min_args, sys_funcs[i].max_args, i);
3202	clisp_init();
3203	current_space=TMP_SPACE;
3204	dprintf("Lisp : %d symbols defined, %d system functions, %d pre-compiled functions\n",
3205	LSymbol::count, sizeof(sys_funcs) / sizeof(*sys_funcs), total_user_functions);
3206	}
3207
3208	void lisp_uninit()
3209	{
3210	free(space[0]);
3211	free(space[1]);
3212	DeleteAllSymbols(LSymbol::root);
3213	LSymbol::root = NULL;
3214	LSymbol::count = 0;
3215	}
3216
3217	void clear_tmp()
3218	{
3219	free_space[TMP_SPACE] = space[TMP_SPACE];
3220	}
3221
3222	LString *LSymbol::GetName()
3223	{
3224	#ifdef TYPE_CHECKING
3225	if (item_type(this) != L_SYMBOL)
3226	{
3227	Print();
3228	lbreak("is not a symbol\n");
3229	exit(0);
3230	}
3231	#endif
3232	return name;
3233	}
3234
3235	void LSymbol::SetNumber(long num)
3236	{
3237	#ifdef TYPE_CHECKING
3238	if (item_type(this) != L_SYMBOL)
3239	{
3240	Print();
3241	lbreak("is not a symbol\n");
3242	exit(0);
3243	}
3244	#endif
3245	if (value != l_undefined && item_type(value) == L_NUMBER)
3246	((LNumber *)value)->num = num;
3247	else
3248	value = LNumber::Create(num);
3249	}
3250
3251	void LSymbol::SetValue(LObject *val)
3252	{
3253	#ifdef TYPE_CHECKING
3254	if (item_type(this) != L_SYMBOL)
3255	{
3256	Print();
3257	lbreak("is not a symbol\n");
3258	exit(0);
3259	}
3260	#endif
3261	value = val;
3262	}
3263
3264	LObject *LSymbol::GetFunction()
3265	{
3266	#ifdef TYPE_CHECKING
3267	if (item_type(this) != L_SYMBOL)
3268	{
3269	Print();
3270	lbreak("is not a symbol\n");
3271	exit(0);
3272	}
3273	#endif
3274	return function;
3275	}
3276
3277	LObject *LSymbol::GetValue()
3278	{
3279	#ifdef TYPE_CHECKING
3280	if (item_type(this) != L_SYMBOL)
3281	{
3282	Print();
3283	lbreak("is not a symbol\n");
3284	exit(0);
3285	}
3286	#endif
3287	return value;
3288	}
3289

Note: See TracBrowser for help on using the repository browser.

Download in other formats: