Context Navigation

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

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

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

Download in other formats: