ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/cvsroot/microscheme/scheme.c

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.33 by root, Sat Nov 28 10:59:14 2015 UTC vs.
Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC

…		…
16	* (MINISCM) This is a revised and modified version by Akira KIDA.	16	* (MINISCM) This is a revised and modified version by Akira KIDA.
17	* (MINISCM) current version is 0.85k4 (15 May 1994)	17	* (MINISCM) current version is 0.85k4 (15 May 1994)
18	*	18	*
19	*/	19	*/
20		20
		21	#define EXPERIMENT 1
		22
		23	#if 1
21	#define PAGE_SIZE 4096 /* does not work on sparc/alpha */	24	#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
22	#include "malloc.c"	25	#include "malloc.c"
		26	#endif
23		27
24	#define SCHEME_SOURCE	28	#define SCHEME_SOURCE
25	#include "scheme-private.h"	29	#include "scheme-private.h"
26	#ifndef WIN32	30	#ifndef WIN32
27	# include <unistd.h>	31	# include <unistd.h>
…		…
34		38
35	#include <sys/types.h>	39	#include <sys/types.h>
36	#include <sys/stat.h>	40	#include <sys/stat.h>
37	#include <fcntl.h>	41	#include <fcntl.h>
38		42
		43	#if !USE_ERROR_CHECKING
		44	# define NDEBUG
		45	#endif
		46
		47	#include <assert.h>
		48	#include <stdlib.h>
39	#include <string.h>	49	#include <string.h>
40	#include <stdlib.h>
41		50
42	#include <limits.h>	51	#include <limits.h>
43	#include <inttypes.h>	52	#include <inttypes.h>
44	#include <float.h>	53	#include <float.h>
45	//#include <ctype.h>	54	//#include <ctype.h>
		55
		56	#if '1' != '0' + 1 \
		57	|| '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
		58	|| '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
		59	|| 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
		60	|| 'f' != 'a' + 5
		61	# error "execution character set digits not consecutive"
		62	#endif
46		63
47	enum {	64	enum {
48	TOK_EOF,	65	TOK_EOF,
49	TOK_LPAREN,	66	TOK_LPAREN,
50	TOK_RPAREN,	67	TOK_RPAREN,
51	TOK_DOT,	68	TOK_DOT,
52	TOK_ATOM,	69	TOK_ATOM,
		70	TOK_DOTATOM, /* atom name starting with '.' */
		71	TOK_STRATOM, /* atom name enclosed in | */
53	TOK_QUOTE,	72	TOK_QUOTE,
54	TOK_DQUOTE,	73	TOK_DQUOTE,
55	TOK_BQUOTE,	74	TOK_BQUOTE,
56	TOK_COMMA,	75	TOK_COMMA,
57	TOK_ATMARK,	76	TOK_ATMARK,
…		…
59	TOK_SHARP_CONST,	78	TOK_SHARP_CONST,
60	TOK_VEC	79	TOK_VEC
61	};	80	};
62		81
63	#define BACKQUOTE '`'	82	#define BACKQUOTE '`'
64	#define DELIMITERS "()\";\f\t\v\n\r "	83	#define WHITESPACE " \t\r\n\v\f"
		84	#define DELIMITERS "()\";" WHITESPACE
65		85
66	#define NIL (&SCHEME_V->xNIL) //TODO: make this 0?	86	#define NIL POINTER (&SCHEME_V->xNIL)
67	#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?	87	#define S_T POINTER (&SCHEME_V->xT)
68	#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?	88	#define S_F POINTER (&SCHEME_V->xF)
69	#define S_SINK (&SCHEME_V->xsink)	89	#define S_SINK POINTER (&SCHEME_V->xsink)
70	#define S_EOF (&SCHEME_V->xEOF_OBJ)	90	#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
71		91
72	#if !USE_MULTIPLICITY	92	#if !USE_MULTIPLICITY
73	static scheme sc;	93	static scheme sc;
74	#endif	94	#endif
75		95
76	static void	96	ecb_cold static void
77	xbase (char *s, long n, int base)	97	xbase (char *s, long n, int base)
78	{	98	{
79	if (n < 0)	99	if (n < 0)
80	{	100	{
81	*s++ = '-';	101	*s++ = '-';
…		…
83	}	103	}
84		104
85	char *p = s;	105	char *p = s;
86		106
87	do {	107	do {
88	*p++ = '0' + n % base;	108	*p++ = "0123456789abcdef"[n % base];
89	n /= base;	109	n /= base;
90	} while (n);	110	} while (n);
91		111
92	*p-- = 0;	112	*p-- = 0;
93		113
…		…
96	char x = *s; *s = *p; *p = x;	116	char x = *s; *s = *p; *p = x;
97	--p; ++s;	117	--p; ++s;
98	}	118	}
99	}	119	}
100		120
101	static void	121	ecb_cold static void
102	xnum (char *s, long n)	122	xnum (char *s, long n)
103	{	123	{
104	xbase (s, n, 10);	124	xbase (s, n, 10);
105	}	125	}
106		126
107	static void	127	ecb_cold static void
108	xwrstr (const char *s)	128	putnum (SCHEME_P_ long n)
109	{
110	write (1, s, strlen (s));
111	}
112
113	static void
114	xwrnum (long n)
115	{	129	{
116	char buf[64];	130	char buf[64];
117		131
118	xnum (buf, n);	132	xnum (buf, n);
119	xwrstr (buf);	133	putstr (SCHEME_A_ buf);
120	}	134	}
121		135
122	static char	136	ecb_cold static char
123	xtoupper (char c)	137	xtoupper (char c)
124	{	138	{
125	if (c >= 'a' && c <= 'z')	139	if (c >= 'a' && c <= 'z')
126	c -= 'a' - 'A';	140	c -= 'a' - 'A';
127		141
128	return c;	142	return c;
129	}	143	}
130		144
131	static char	145	ecb_cold static char
132	xtolower (char c)	146	xtolower (char c)
133	{	147	{
134	if (c >= 'A' && c <= 'Z')	148	if (c >= 'A' && c <= 'Z')
135	c += 'a' - 'A';	149	c += 'a' - 'A';
136		150
137	return c;	151	return c;
138	}	152	}
139		153
140	static int	154	ecb_cold static int
141	xisdigit (char c)	155	xisdigit (char c)
142	{	156	{
143	return c >= '0' && c <= '9';	157	return c >= '0' && c <= '9';
144	}	158	}
145		159
146	#define toupper(c) xtoupper (c)	160	#define toupper(c) xtoupper (c)
147	#define tolower(c) xtolower (c)	161	#define tolower(c) xtolower (c)
148	#define isdigit(c) xisdigit (c)	162	#define isdigit(c) xisdigit (c)
149		163
150	#if USE_IGNORECASE	164	#if USE_IGNORECASE
151	static const char *	165	ecb_cold static const char *
152	xstrlwr (char *s)	166	xstrlwr (char *s)
153	{	167	{
154	const char *p = s;	168	const char *p = s;
155		169
156	while (*s)	170	while (*s)
…		…
176		190
177	#ifndef InitFile	191	#ifndef InitFile
178	# define InitFile "init.scm"	192	# define InitFile "init.scm"
179	#endif	193	#endif
180		194
181	#ifndef FIRST_CELLSEGS
182	# define FIRST_CELLSEGS 3
183	#endif
184
185	enum scheme_types	195	enum scheme_types
186	{	196	{
187	T_INTEGER,	197	T_INTEGER,
		198	T_CHARACTER,
188	T_REAL,	199	T_REAL,
189	T_STRING,	200	T_STRING,
190	T_SYMBOL,	201	T_SYMBOL,
191	T_PROC,	202	T_PROC,
192	T_PAIR, /* also used for free cells */	203	T_PAIR, /* also used for free cells */
193	T_CLOSURE,	204	T_CLOSURE,
		205	T_MACRO,
194	T_CONTINUATION,	206	T_CONTINUATION,
195	T_FOREIGN,	207	T_FOREIGN,
196	T_CHARACTER,
197	T_PORT,	208	T_PORT,
198	T_VECTOR,	209	T_VECTOR,
199	T_MACRO,
200	T_PROMISE,	210	T_PROMISE,
201	T_ENVIRONMENT,	211	T_ENVIRONMENT,
202	/* one more... */	212	/* one more... */
203	T_NUM_SYSTEM_TYPES	213	T_NUM_SYSTEM_TYPES
204	};	214	};
…		…
240	static num num_op (enum num_op op, num a, num b);	250	static num num_op (enum num_op op, num a, num b);
241	static num num_intdiv (num a, num b);	251	static num num_intdiv (num a, num b);
242	static num num_rem (num a, num b);	252	static num num_rem (num a, num b);
243	static num num_mod (num a, num b);	253	static num num_mod (num a, num b);
244		254
245	#if USE_MATH
246	static double round_per_R5RS (double x);
247	#endif
248	static int is_zero_rvalue (RVALUE x);	255	static int is_zero_rvalue (RVALUE x);
249		256
250	static num num_zero;	257	static num num_zero;
251	static num num_one;	258	static num num_one;
252		259
		260	/* convert "pointer" to cell* / cell* to pointer */
		261	#define CELL(p) ((struct cell *)(p) + 0)
		262	#define POINTER(c) ((void *)((c) - 0))
		263
253	/* macros for cell operations */	264	/* macros for cell operations */
254	#define typeflag(p) ((p)->flag + 0)	265	#define typeflag(p) (CELL(p)->flag + 0)
255	#define set_typeflag(p,v) ((p)->flag = (v))	266	#define set_typeflag(p,v) (CELL(p)->flag = (v))
256	#define type(p) (typeflag (p) & T_MASKTYPE)	267	#define type(p) (typeflag (p) & T_MASKTYPE)
257		268
258	INTERFACE int	269	INTERFACE int
259	is_string (pointer p)	270	is_string (pointer p)
260	{	271	{
261	return type (p) == T_STRING;	272	return type (p) == T_STRING;
262	}	273	}
263		274
264	#define strvalue(p) ((p)->object.string.svalue)	275	#define strvalue(p) (CELL(p)->object.string.svalue)
265	#define strlength(p) ((p)->object.string.length)	276	#define strlength(p) (CELL(p)->object.string.length)
266		277
267	INTERFACE int	278	INTERFACE int
268	is_vector (pointer p)	279	is_vector (pointer p)
269	{	280	{
270	return type (p) == T_VECTOR;	281	return type (p) == T_VECTOR;
271	}	282	}
272		283
273	#define vecvalue(p) ((p)->object.vector.vvalue)	284	#define vecvalue(p) (CELL(p)->object.vector.vvalue)
274	#define veclength(p) ((p)->object.vector.length)	285	#define veclength(p) (CELL(p)->object.vector.length)
275	INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);	286	INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
276	INTERFACE pointer vector_get (pointer vec, uint32_t ielem);	287	INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
277	INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);	288	INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
278		289
279	INTERFACE int	290	INTERFACE int
…		…
305	string_value (pointer p)	316	string_value (pointer p)
306	{	317	{
307	return strvalue (p);	318	return strvalue (p);
308	}	319	}
309		320
310	#define ivalue_unchecked(p) (p)->object.ivalue	321	#define ivalue_unchecked(p) CELL(p)->object.ivalue
311	#define set_ivalue(p,v) (p)->object.ivalue = (v)	322	#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
312		323
313	#if USE_REAL	324	#if USE_REAL
314	#define rvalue_unchecked(p) (p)->object.rvalue	325	#define rvalue_unchecked(p) CELL(p)->object.rvalue
315	#define set_rvalue(p,v) (p)->object.rvalue = (v)	326	#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
316	#else	327	#else
317	#define rvalue_unchecked(p) (p)->object.ivalue	328	#define rvalue_unchecked(p) CELL(p)->object.ivalue
318	#define set_rvalue(p,v) (p)->object.ivalue = (v)	329	#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
319	#endif	330	#endif
320		331
321	INTERFACE long	332	INTERFACE long
322	charvalue (pointer p)	333	charvalue (pointer p)
323	{	334	{
324	return ivalue_unchecked (p);	335	return ivalue_unchecked (p);
325	}	336	}
326		337
		338	#define port(p) CELL(p)->object.port
		339	#define set_port(p,v) port(p) = (v)
327	INTERFACE int	340	INTERFACE int
328	is_port (pointer p)	341	is_port (pointer p)
329	{	342	{
330	return type (p) == T_PORT;	343	return type (p) == T_PORT;
331	}	344	}
332		345
333	INTERFACE int	346	INTERFACE int
334	is_inport (pointer p)	347	is_inport (pointer p)
335	{	348	{
336	return is_port (p) && p->object.port->kind & port_input;	349	return is_port (p) && port (p)->kind & port_input;
337	}	350	}
338		351
339	INTERFACE int	352	INTERFACE int
340	is_outport (pointer p)	353	is_outport (pointer p)
341	{	354	{
342	return is_port (p) && p->object.port->kind & port_output;	355	return is_port (p) && port (p)->kind & port_output;
343	}	356	}
344		357
345	INTERFACE int	358	INTERFACE int
346	is_pair (pointer p)	359	is_pair (pointer p)
347	{	360	{
348	return type (p) == T_PAIR;	361	return type (p) == T_PAIR;
349	}	362	}
350		363
351	#define car(p) ((p)->object.cons.car + 0)	364	#define car(p) (POINTER (CELL(p)->object.cons.car))
352	#define cdr(p) ((p)->object.cons.cdr + 0)	365	#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
353		366
354	static pointer caar (pointer p) { return car (car (p)); }	367	static pointer caar (pointer p) { return car (car (p)); }
355	static pointer cadr (pointer p) { return car (cdr (p)); }	368	static pointer cadr (pointer p) { return car (cdr (p)); }
356	static pointer cdar (pointer p) { return cdr (car (p)); }	369	static pointer cdar (pointer p) { return cdr (car (p)); }
357	static pointer cddr (pointer p) { return cdr (cdr (p)); }	370	static pointer cddr (pointer p) { return cdr (cdr (p)); }
…		…
361	static pointer cdaar (pointer p) { return cdr (car (car (p))); }	374	static pointer cdaar (pointer p) { return cdr (car (car (p))); }
362		375
363	INTERFACE void	376	INTERFACE void
364	set_car (pointer p, pointer q)	377	set_car (pointer p, pointer q)
365	{	378	{
366	p->object.cons.car = q;	379	CELL(p)->object.cons.car = CELL (q);
367	}	380	}
368		381
369	INTERFACE void	382	INTERFACE void
370	set_cdr (pointer p, pointer q)	383	set_cdr (pointer p, pointer q)
371	{	384	{
372	p->object.cons.cdr = q;	385	CELL(p)->object.cons.cdr = CELL (q);
373	}	386	}
374		387
375	INTERFACE pointer	388	INTERFACE pointer
376	pair_car (pointer p)	389	pair_car (pointer p)
377	{	390	{
…		…
391	}	404	}
392		405
393	INTERFACE char *	406	INTERFACE char *
394	symname (pointer p)	407	symname (pointer p)
395	{	408	{
396	return strvalue (car (p));	409	return strvalue (p);
397	}	410	}
398		411
399	#if USE_PLIST	412	#if USE_PLIST
		413	#error plists are broken because symbols are no longer pairs
		414	#define symprop(p) cdr(p)
400	SCHEME_EXPORT int	415	SCHEME_EXPORT int
401	hasprop (pointer p)	416	hasprop (pointer p)
402	{	417	{
403	return typeflag (p) & T_SYMBOL;	418	return typeflag (p) & T_SYMBOL;
404	}	419	}
405
406	# define symprop(p) cdr(p)
407	#endif	420	#endif
408		421
409	INTERFACE int	422	INTERFACE int
410	is_syntax (pointer p)	423	is_syntax (pointer p)
411	{	424	{
…		…
425	}	438	}
426		439
427	INTERFACE char *	440	INTERFACE char *
428	syntaxname (pointer p)	441	syntaxname (pointer p)
429	{	442	{
430	return strvalue (car (p));	443	return strvalue (p);
431	}	444	}
432		445
433	#define procnum(p) ivalue_unchecked (p)	446	#define procnum(p) ivalue_unchecked (p)
434	static const char *procname (pointer x);	447	static const char *procname (pointer x);
435		448
…		…
507	proper list: length	520	proper list: length
508	circular list: -1	521	circular list: -1
509	not even a pair: -2	522	not even a pair: -2
510	dotted list: -2 minus length before dot	523	dotted list: -2 minus length before dot
511	*/	524	*/
512	INTERFACE int	525	ecb_hot INTERFACE int
513	list_length (SCHEME_P_ pointer a)	526	list_length (SCHEME_P_ pointer a)
514	{	527	{
515	int i = 0;	528	int i = 0;
516	pointer slow, fast;	529	pointer slow, fast;
517		530
…		…
623	"gs",	636	"gs",
624	"rs",	637	"rs",
625	"us"	638	"us"
626	};	639	};
627		640
628	static int	641	ecb_cold static int
629	is_ascii_name (const char *name, int *pc)	642	is_ascii_name (const char *name, int *pc)
630	{	643	{
631	int i;	644	int i;
632		645
633	for (i = 0; i < 32; i++)	646	for (i = 0; i < 32; i++)
…		…
651	#endif	664	#endif
652		665
653	static int file_push (SCHEME_P_ const char *fname);	666	static int file_push (SCHEME_P_ const char *fname);
654	static void file_pop (SCHEME_P);	667	static void file_pop (SCHEME_P);
655	static int file_interactive (SCHEME_P);	668	static int file_interactive (SCHEME_P);
656	ecb_inline int is_one_of (char *s, int c);	669	ecb_inline int is_one_of (const char *s, int c);
657	static int alloc_cellseg (SCHEME_P_ int n);	670	static int alloc_cellseg (SCHEME_P);
658	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);	671	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
659	static void finalize_cell (SCHEME_P_ pointer a);	672	static void finalize_cell (SCHEME_P_ pointer a);
660	static int count_consecutive_cells (pointer x, int needed);	673	static int count_consecutive_cells (pointer x, int needed);
661	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	674	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
662	static pointer mk_number (SCHEME_P_ const num n);	675	static pointer mk_number (SCHEME_P_ const num n);
…		…
678	static void mark (pointer a);	691	static void mark (pointer a);
679	static void gc (SCHEME_P_ pointer a, pointer b);	692	static void gc (SCHEME_P_ pointer a, pointer b);
680	static int basic_inchar (port *pt);	693	static int basic_inchar (port *pt);
681	static int inchar (SCHEME_P);	694	static int inchar (SCHEME_P);
682	static void backchar (SCHEME_P_ int c);	695	static void backchar (SCHEME_P_ int c);
683	static char *readstr_upto (SCHEME_P_ char *delim);	696	static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
684	static pointer readstrexp (SCHEME_P);	697	static pointer readstrexp (SCHEME_P_ char delim);
685	ecb_inline int skipspace (SCHEME_P);	698	ecb_inline int skipspace (SCHEME_P);
686	static int token (SCHEME_P);	699	static int token (SCHEME_P);
687	static void printslashstring (SCHEME_P_ char *s, int len);	700	static void printslashstring (SCHEME_P_ char *s, int len);
688	static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);	701	static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
689	static void printatom (SCHEME_P_ pointer l, int f);	702	static void printatom (SCHEME_P_ pointer l, int f);
…		…
856	}	869	}
857		870
858	return ret;	871	return ret;
859	}	872	}
860		873
861	#if USE_MATH
862
863	/* Round to nearest. Round to even if midway */
864	static double
865	round_per_R5RS (double x)
866	{
867	double fl = floor (x);
868	double ce = ceil (x);
869	double dfl = x - fl;
870	double dce = ce - x;
871
872	if (dfl > dce)
873	return ce;
874	else if (dfl < dce)
875	return fl;
876	else
877	{
878	if (fmod (fl, 2) == 0) /* I imagine this holds */
879	return fl;
880	else
881	return ce;
882	}
883	}
884	#endif
885
886	static int	874	static int
887	is_zero_rvalue (RVALUE x)	875	is_zero_rvalue (RVALUE x)
888	{	876	{
889	return x == 0;	877	return x == 0;
890	#if 0	878	#if 0
…		…
895	#endif	883	#endif
896	#endif	884	#endif
897	}	885	}
898		886
899	/* allocate new cell segment */	887	/* allocate new cell segment */
900	static int	888	ecb_cold static int
901	alloc_cellseg (SCHEME_P_ int n)	889	alloc_cellseg (SCHEME_P)
902	{	890	{
903	pointer newp;	891	struct cell *newp;
904	pointer last;	892	struct cell *last;
905	pointer p;	893	struct cell *p;
906	char *cp;	894	char *cp;
907	long i;	895	long i;
908	int k;	896	int k;
909		897
910	static int segsize = CELL_SEGSIZE >> 1;	898	static int segsize = CELL_SEGSIZE >> 1;
911	segsize <<= 1;	899	segsize <<= 1;
912		900
913	for (k = 0; k < n; k++)
914	{
915	if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
916	return k;
917
918	cp = malloc (segsize * sizeof (struct cell));	901	cp = malloc (segsize * sizeof (struct cell));
919		902
920	if (!cp && USE_ERROR_CHECKING)	903	if (!cp && USE_ERROR_CHECKING)
921	return k;	904	return k;
922		905
923	i = ++SCHEME_V->last_cell_seg;	906	i = ++SCHEME_V->last_cell_seg;
924	SCHEME_V->alloc_seg[i] = cp;	907	SCHEME_V->alloc_seg[i] = cp;
925		908
926	newp = (pointer)cp;	909	newp = (struct cell *)cp;
927	SCHEME_V->cell_seg[i] = newp;	910	SCHEME_V->cell_seg[i] = newp;
928	SCHEME_V->cell_segsize[i] = segsize;	911	SCHEME_V->cell_segsize[i] = segsize;
929	SCHEME_V->fcells += segsize;	912	SCHEME_V->fcells += segsize;
930	last = newp + segsize - 1;	913	last = newp + segsize - 1;
931		914
932	for (p = newp; p <= last; p++)	915	for (p = newp; p <= last; p++)
933	{	916	{
		917	pointer cp = POINTER (p);
934	set_typeflag (p, T_PAIR);	918	set_typeflag (cp, T_PAIR);
935	set_car (p, NIL);	919	set_car (cp, NIL);
936	set_cdr (p, p + 1);	920	set_cdr (cp, POINTER (p + 1));
937	}	921	}
938		922
939	set_cdr (last, SCHEME_V->free_cell);	923	set_cdr (POINTER (last), SCHEME_V->free_cell);
940	SCHEME_V->free_cell = newp;	924	SCHEME_V->free_cell = POINTER (newp);
941	}
942		925
943	return n;	926	return 1;
944	}	927	}
945		928
946	/* get new cell. parameter a, b is marked by gc. */	929	/* get new cell. parameter a, b is marked by gc. */
947	ecb_inline pointer	930	ecb_inline pointer
948	get_cell_x (SCHEME_P_ pointer a, pointer b)	931	get_cell_x (SCHEME_P_ pointer a, pointer b)
…		…
952	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	935	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
953	return S_SINK;	936	return S_SINK;
954		937
955	if (SCHEME_V->free_cell == NIL)	938	if (SCHEME_V->free_cell == NIL)
956	{	939	{
957	const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8;	940	const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1;
958		941
959	gc (SCHEME_A_ a, b);	942	gc (SCHEME_A_ a, b);
960		943
961	if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)	944	if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
962	{	945	{
963	/* if only a few recovered, get more to avoid fruitless gc's */	946	/* if only a few recovered, get more to avoid fruitless gc's */
964	if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL)	947	if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
965	{	948	{
966	#if USE_ERROR_CHECKING	949	#if USE_ERROR_CHECKING
967	SCHEME_V->no_memory = 1;	950	SCHEME_V->no_memory = 1;
968	return S_SINK;	951	return S_SINK;
969	#endif	952	#endif
…		…
981	}	964	}
982	}	965	}
983		966
984	/* To retain recent allocs before interpreter knows about them -	967	/* To retain recent allocs before interpreter knows about them -
985	Tehom */	968	Tehom */
986		969	ecb_hot static void
987	static void
988	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)	970	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
989	{	971	{
990	pointer holder = get_cell_x (SCHEME_A_ recent, extra);	972	pointer holder = get_cell_x (SCHEME_A_ recent, extra);
991		973
992	set_typeflag (holder, T_PAIR);	974	set_typeflag (holder, T_PAIR);
…		…
994	set_car (holder, recent);	976	set_car (holder, recent);
995	set_cdr (holder, car (S_SINK));	977	set_cdr (holder, car (S_SINK));
996	set_car (S_SINK, holder);	978	set_car (S_SINK, holder);
997	}	979	}
998		980
999	static pointer	981	ecb_hot static pointer
1000	get_cell (SCHEME_P_ pointer a, pointer b)	982	get_cell (SCHEME_P_ pointer a, pointer b)
1001	{	983	{
1002	pointer cell = get_cell_x (SCHEME_A_ a, b);	984	pointer cell = get_cell_x (SCHEME_A_ a, b);
1003		985
1004	/* For right now, include "a" and "b" in "cell" so that gc doesn't	986	/* For right now, include "a" and "b" in "cell" so that gc doesn't
…		…
1013	}	995	}
1014		996
1015	static pointer	997	static pointer
1016	get_vector_object (SCHEME_P_ uint32_t len, pointer init)	998	get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1017	{	999	{
1018	pointer v = get_cell_x (SCHEME_A_ 0, 0);	1000	pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1019	pointer *e = malloc (len * sizeof (pointer));	1001	pointer *e = malloc (len * sizeof (pointer));
1020		1002
1021	if (!e && USE_ERROR_CHECKING)	1003	if (!e && USE_ERROR_CHECKING)
1022	return S_SINK;	1004	return S_SINK;
1023		1005
1024	/* Record it as a vector so that gc understands it. */	1006	/* Record it as a vector so that gc understands it. */
1025	set_typeflag (v, T_VECTOR | T_ATOM);	1007	set_typeflag (v, T_VECTOR | T_ATOM);
1026		1008
1027	v->object.vector.vvalue = e;	1009	CELL(v)->object.vector.vvalue = e;
1028	v->object.vector.length = len;	1010	CELL(v)->object.vector.length = len;
1029	fill_vector (v, 0, init);	1011	fill_vector (v, 0, init);
1030	push_recent_alloc (SCHEME_A_ v, NIL);	1012	push_recent_alloc (SCHEME_A_ v, NIL);
1031		1013
1032	return v;	1014	return v;
1033	}	1015	}
…		…
1042	static void	1024	static void
1043	check_cell_alloced (pointer p, int expect_alloced)	1025	check_cell_alloced (pointer p, int expect_alloced)
1044	{	1026	{
1045	/* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */	1027	/* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1046	if (typeflag (p) & !expect_alloced)	1028	if (typeflag (p) & !expect_alloced)
1047	xwrstr ("Cell is already allocated!\n");	1029	putstr (SCHEME_A_ "Cell is already allocated!\n");
1048		1030
1049	if (!(typeflag (p)) & expect_alloced)	1031	if (!(typeflag (p)) & expect_alloced)
1050	xwrstr ("Cell is not allocated!\n");	1032	putstr (SCHEME_A_ "Cell is not allocated!\n");
1051	}	1033	}
1052		1034
1053	static void	1035	static void
1054	check_range_alloced (pointer p, int n, int expect_alloced)	1036	check_range_alloced (pointer p, int n, int expect_alloced)
1055	{	1037	{
…		…
1061	#endif	1043	#endif
1062		1044
1063	/* Medium level cell allocation */	1045	/* Medium level cell allocation */
1064		1046
1065	/* get new cons cell */	1047	/* get new cons cell */
1066	pointer	1048	ecb_hot pointer
1067	xcons (SCHEME_P_ pointer a, pointer b, int immutable)	1049	xcons (SCHEME_P_ pointer a, pointer b, int immutable)
1068	{	1050	{
1069	pointer x = get_cell (SCHEME_A_ a, b);	1051	pointer x = get_cell (SCHEME_A_ a, b);
1070		1052
1071	set_typeflag (x, T_PAIR);	1053	set_typeflag (x, T_PAIR);
…		…
1077	set_cdr (x, b);	1059	set_cdr (x, b);
1078		1060
1079	return x;	1061	return x;
1080	}	1062	}
1081		1063
		1064	ecb_cold static pointer
		1065	generate_symbol (SCHEME_P_ const char *name)
		1066	{
		1067	pointer x = mk_string (SCHEME_A_ name);
		1068	setimmutable (x);
		1069	set_typeflag (x, T_SYMBOL | T_ATOM);
		1070	return x;
		1071	}
		1072
1082	/* ========== oblist implementation ========== */	1073	/* ========== oblist implementation ========== */
1083		1074
1084	#ifndef USE_OBJECT_LIST	1075	#ifndef USE_OBJECT_LIST
1085		1076
1086	static int	1077	static int
…		…
1093	hash = (hash ^ *p++) * 16777619;	1084	hash = (hash ^ *p++) * 16777619;
1094		1085
1095	return hash % table_size;	1086	return hash % table_size;
1096	}	1087	}
1097		1088
1098	static pointer	1089	ecb_cold static pointer
1099	oblist_initial_value (SCHEME_P)	1090	oblist_initial_value (SCHEME_P)
1100	{	1091	{
1101	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */	1092	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1102	}	1093	}
1103		1094
1104	/* returns the new symbol */	1095	/* returns the new symbol */
1105	static pointer	1096	ecb_cold static pointer
1106	oblist_add_by_name (SCHEME_P_ const char *name)	1097	oblist_add_by_name (SCHEME_P_ const char *name)
1107	{	1098	{
1108	int location;	1099	pointer x = generate_symbol (SCHEME_A_ name);
1109
1110	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1111	set_typeflag (x, T_SYMBOL);
1112	setimmutable (car (x));
1113
1114	location = hash_fn (name, veclength (SCHEME_V->oblist));	1100	int location = hash_fn (name, veclength (SCHEME_V->oblist));
1115	vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));	1101	vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1116	return x;	1102	return x;
1117	}	1103	}
1118		1104
1119	ecb_inline pointer	1105	ecb_cold static pointer
1120	oblist_find_by_name (SCHEME_P_ const char *name)	1106	oblist_find_by_name (SCHEME_P_ const char *name)
1121	{	1107	{
1122	int location;	1108	int location;
1123	pointer x;	1109	pointer x;
1124	char *s;	1110	char *s;
…		…
1135	}	1121	}
1136		1122
1137	return NIL;	1123	return NIL;
1138	}	1124	}
1139		1125
1140	static pointer	1126	ecb_cold static pointer
1141	oblist_all_symbols (SCHEME_P)	1127	oblist_all_symbols (SCHEME_P)
1142	{	1128	{
1143	int i;	1129	int i;
1144	pointer x;	1130	pointer x;
1145	pointer ob_list = NIL;	1131	pointer ob_list = NIL;
…		…
1151	return ob_list;	1137	return ob_list;
1152	}	1138	}
1153		1139
1154	#else	1140	#else
1155		1141
1156	static pointer	1142	ecb_cold static pointer
1157	oblist_initial_value (SCHEME_P)	1143	oblist_initial_value (SCHEME_P)
1158	{	1144	{
1159	return NIL;	1145	return NIL;
1160	}	1146	}
1161		1147
1162	ecb_inline pointer	1148	ecb_cold static pointer
1163	oblist_find_by_name (SCHEME_P_ const char *name)	1149	oblist_find_by_name (SCHEME_P_ const char *name)
1164	{	1150	{
1165	pointer x;	1151	pointer x;
1166	char *s;	1152	char *s;
1167		1153
…		…
1176		1162
1177	return NIL;	1163	return NIL;
1178	}	1164	}
1179		1165
1180	/* returns the new symbol */	1166	/* returns the new symbol */
1181	static pointer	1167	ecb_cold static pointer
1182	oblist_add_by_name (SCHEME_P_ const char *name)	1168	oblist_add_by_name (SCHEME_P_ const char *name)
1183	{	1169	{
1184	pointer x = mk_string (SCHEME_A_ name);	1170	pointer x = generate_symbol (SCHEME_A_ name);
1185	set_typeflag (x, T_SYMBOL);
1186	setimmutable (x);
1187	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);	1171	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1188	return x;	1172	return x;
1189	}	1173	}
1190		1174
1191	static pointer	1175	ecb_cold static pointer
1192	oblist_all_symbols (SCHEME_P)	1176	oblist_all_symbols (SCHEME_P)
1193	{	1177	{
1194	return SCHEME_V->oblist;	1178	return SCHEME_V->oblist;
1195	}	1179	}
1196		1180
1197	#endif	1181	#endif
1198		1182
1199	#if USE_PORTS	1183	#if USE_PORTS
1200	static pointer	1184	ecb_cold static pointer
1201	mk_port (SCHEME_P_ port *p)	1185	mk_port (SCHEME_P_ port *p)
1202	{	1186	{
1203	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1187	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1204		1188
1205	set_typeflag (x, T_PORT | T_ATOM);	1189	set_typeflag (x, T_PORT | T_ATOM);
1206	x->object.port = p;	1190	set_port (x, p);
1207		1191
1208	return x;	1192	return x;
1209	}	1193	}
1210	#endif	1194	#endif
1211		1195
1212	pointer	1196	ecb_cold pointer
1213	mk_foreign_func (SCHEME_P_ foreign_func f)	1197	mk_foreign_func (SCHEME_P_ foreign_func f)
1214	{	1198	{
1215	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1199	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1216		1200
1217	set_typeflag (x, (T_FOREIGN | T_ATOM));	1201	set_typeflag (x, T_FOREIGN | T_ATOM);
1218	x->object.ff = f;	1202	CELL(x)->object.ff = f;
1219		1203
1220	return x;	1204	return x;
1221	}	1205	}
1222		1206
1223	INTERFACE pointer	1207	INTERFACE pointer
1224	mk_character (SCHEME_P_ int c)	1208	mk_character (SCHEME_P_ int c)
1225	{	1209	{
1226	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1210	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1227		1211
1228	set_typeflag (x, (T_CHARACTER | T_ATOM));	1212	set_typeflag (x, T_CHARACTER | T_ATOM);
1229	set_ivalue (x, c & 0xff);	1213	set_ivalue (x, c & 0xff);
1230		1214
1231	return x;	1215	return x;
1232	}	1216	}
1233		1217
1234	/* get number atom (integer) */	1218	/* get number atom (integer) */
1235	INTERFACE pointer	1219	INTERFACE pointer
1236	mk_integer (SCHEME_P_ long n)	1220	mk_integer (SCHEME_P_ long n)
1237	{	1221	{
		1222	pointer p = 0;
		1223	pointer *pp = &p;
		1224
		1225	#if USE_INTCACHE
		1226	if (n >= INTCACHE_MIN && n <= INTCACHE_MAX)
		1227	pp = &SCHEME_V->intcache[n - INTCACHE_MIN];
		1228	#endif
		1229
		1230	if (!*pp)
		1231	{
1238	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1232	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1239		1233
1240	set_typeflag (x, (T_INTEGER | T_ATOM));	1234	set_typeflag (x, T_INTEGER | T_ATOM);
		1235	setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
1241	set_ivalue (x, n);	1236	set_ivalue (x, n);
1242		1237
		1238	*pp = x;
		1239	}
		1240
1243	return x;	1241	return *pp;
1244	}	1242	}
1245		1243
1246	INTERFACE pointer	1244	INTERFACE pointer
1247	mk_real (SCHEME_P_ RVALUE n)	1245	mk_real (SCHEME_P_ RVALUE n)
1248	{	1246	{
1249	#if USE_REAL	1247	#if USE_REAL
1250	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1248	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1251		1249
1252	set_typeflag (x, (T_REAL | T_ATOM));	1250	set_typeflag (x, T_REAL | T_ATOM);
1253	set_rvalue (x, n);	1251	set_rvalue (x, n);
1254		1252
1255	return x;	1253	return x;
1256	#else	1254	#else
1257	return mk_integer (SCHEME_A_ n);	1255	return mk_integer (SCHEME_A_ n);
…		…
1281	SCHEME_V->no_memory = 1;	1279	SCHEME_V->no_memory = 1;
1282	return SCHEME_V->strbuff;	1280	return SCHEME_V->strbuff;
1283	}	1281	}
1284		1282
1285	if (str)	1283	if (str)
1286	{	1284	memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
1287	int l = strlen (str);
1288
1289	if (l > len_str)
1290	l = len_str;
1291
1292	memcpy (q, str, l);
1293	q[l] = 0;
1294	}
1295	else	1285	else
1296	{
1297	memset (q, fill, len_str);	1286	memset (q, fill, len_str);
		1287
1298	q[len_str] = 0;	1288	q[len_str] = 0;
1299	}
1300		1289
1301	return q;	1290	return q;
1302	}	1291	}
1303		1292
1304	INTERFACE pointer	1293	INTERFACE pointer
…		…
1318	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1307	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1319		1308
1320	set_typeflag (x, T_STRING | T_ATOM);	1309	set_typeflag (x, T_STRING | T_ATOM);
1321	strvalue (x) = store_string (SCHEME_A_ len, str, 0);	1310	strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1322	strlength (x) = len;	1311	strlength (x) = len;
		1312
1323	return x;	1313	return x;
1324	}	1314	}
1325		1315
1326	INTERFACE pointer	1316	INTERFACE pointer
1327	mk_string (SCHEME_P_ const char *str)	1317	mk_string (SCHEME_P_ const char *str)
…		…
1340	{	1330	{
1341	int i;	1331	int i;
1342		1332
1343	for (i = start; i < veclength (vec); i++)	1333	for (i = start; i < veclength (vec); i++)
1344	vecvalue (vec)[i] = obj;	1334	vecvalue (vec)[i] = obj;
		1335	}
		1336
		1337	INTERFACE void
		1338	vector_resize (pointer vec, uint32_t newsize, pointer fill)
		1339	{
		1340	uint32_t oldsize = veclength (vec);
		1341	vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer));
		1342	veclength (vec) = newsize;
		1343	fill_vector (vec, oldsize, fill);
1345	}	1344	}
1346		1345
1347	INTERFACE pointer	1346	INTERFACE pointer
1348	vector_get (pointer vec, uint32_t ielem)	1347	vector_get (pointer vec, uint32_t ielem)
1349	{	1348	{
…		…
1367	x = oblist_add_by_name (SCHEME_A_ name);	1366	x = oblist_add_by_name (SCHEME_A_ name);
1368		1367
1369	return x;	1368	return x;
1370	}	1369	}
1371		1370
1372	INTERFACE pointer	1371	ecb_cold INTERFACE pointer
1373	gensym (SCHEME_P)	1372	gensym (SCHEME_P)
1374	{	1373	{
1375	pointer x;	1374	pointer x;
1376
1377	for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1378	{
1379	char name[40] = "gensym-";	1375	char name[40] = "gensym-";
1380	xnum (name + 7, SCHEME_V->gensym_cnt);	1376	xnum (name + 7, ++SCHEME_V->gensym_cnt);
1381		1377
1382	/* first check oblist */	1378	return generate_symbol (SCHEME_A_ name);
1383	x = oblist_find_by_name (SCHEME_A_ name);	1379	}
1384		1380
1385	if (x == NIL)	1381	static int
1386	{	1382	is_gensym (SCHEME_P_ pointer x)
1387	x = oblist_add_by_name (SCHEME_A_ name);	1383	{
1388	return x;	1384	return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1389	}
1390	}
1391
1392	return NIL;
1393	}	1385	}
1394		1386
1395	/* make symbol or number atom from string */	1387	/* make symbol or number atom from string */
1396	static pointer	1388	ecb_cold static pointer
1397	mk_atom (SCHEME_P_ char *q)	1389	mk_atom (SCHEME_P_ char *q)
1398	{	1390	{
1399	char c, *p;	1391	char c, *p;
1400	int has_dec_point = 0;	1392	int has_dec_point = 0;
1401	int has_fp_exp = 0;	1393	int has_fp_exp = 0;
…		…
1472		1464
1473	return mk_integer (SCHEME_A_ strtol (q, 0, 10));	1465	return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1474	}	1466	}
1475		1467
1476	/* make constant */	1468	/* make constant */
1477	static pointer	1469	ecb_cold static pointer
1478	mk_sharp_const (SCHEME_P_ char *name)	1470	mk_sharp_const (SCHEME_P_ char *name)
1479	{	1471	{
1480	if (!strcmp (name, "t"))	1472	if (!strcmp (name, "t"))
1481	return S_T;	1473	return S_T;
1482	else if (!strcmp (name, "f"))	1474	else if (!strcmp (name, "f"))
1483	return S_F;	1475	return S_F;
1484	else if (*name == '\\') /* #\w (character) */	1476	else if (*name == '\\') /* #\w (character) */
1485	{	1477	{
1486	int c;	1478	int c;
1487		1479
		1480	// TODO: optimise
1488	if (stricmp (name + 1, "space") == 0)	1481	if (stricmp (name + 1, "space") == 0)
1489	c = ' ';	1482	c = ' ';
1490	else if (stricmp (name + 1, "newline") == 0)	1483	else if (stricmp (name + 1, "newline") == 0)
1491	c = '\n';	1484	c = '\n';
1492	else if (stricmp (name + 1, "return") == 0)	1485	else if (stricmp (name + 1, "return") == 0)
1493	c = '\r';	1486	c = '\r';
1494	else if (stricmp (name + 1, "tab") == 0)	1487	else if (stricmp (name + 1, "tab") == 0)
1495	c = '\t';	1488	c = '\t';
		1489	else if (stricmp (name + 1, "alarm") == 0)
		1490	c = 0x07;
		1491	else if (stricmp (name + 1, "backspace") == 0)
		1492	c = 0x08;
		1493	else if (stricmp (name + 1, "escape") == 0)
		1494	c = 0x1b;
		1495	else if (stricmp (name + 1, "delete") == 0)
		1496	c = 0x7f;
		1497	else if (stricmp (name + 1, "null") == 0)
		1498	c = 0;
1496	else if (name[1] == 'x' && name[2] != 0)	1499	else if (name[1] == 'x' && name[2] != 0)
1497	{	1500	{
1498	long c1 = strtol (name + 2, 0, 16);	1501	long c1 = strtol (name + 2, 0, 16);
1499		1502
1500	if (0 <= c1 && c1 <= UCHAR_MAX)	1503	if (0 <= c1 && c1 <= UCHAR_MAX)
…		…
1525	return NIL;	1528	return NIL;
1526	}	1529	}
1527	}	1530	}
1528		1531
1529	/* ========== garbage collector ========== */	1532	/* ========== garbage collector ========== */
		1533
		1534	static void
		1535	finalize_cell (SCHEME_P_ pointer a)
		1536	{
		1537	/* TODO, fast bitmap check? */
		1538	if (is_string (a) || is_symbol (a))
		1539	free (strvalue (a));
		1540	else if (is_vector (a))
		1541	free (vecvalue (a));
		1542	#if USE_PORTS
		1543	else if (is_port (a))
		1544	{
		1545	if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
		1546	port_close (SCHEME_A_ a, port_input | port_output);
		1547
		1548	free (port (a));
		1549	}
		1550	#endif
		1551	}
1530		1552
1531	/*--	1553	/*--
1532	* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,	1554	* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1533	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,	1555	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1534	* for marking.	1556	* for marking.
1535	*	1557	*
1536	* The exception is vectors - vectors are currently marked recursively,	1558	* The exception is vectors - vectors are currently marked recursively,
1537	* which is inherited form tinyscheme and could be fixed by having another	1559	* which is inherited form tinyscheme and could be fixed by having another
1538	* word of context in the vector	1560	* word of context in the vector
1539	*/	1561	*/
1540	static void	1562	ecb_hot static void
1541	mark (pointer a)	1563	mark (pointer a)
1542	{	1564	{
1543	pointer t, q, p;	1565	pointer t, q, p;
1544		1566
1545	t = 0;	1567	t = 0;
…		…
1602	p = q;	1624	p = q;
1603	goto E6;	1625	goto E6;
1604	}	1626	}
1605	}	1627	}
1606		1628
		1629	ecb_hot static void
		1630	gc_free (SCHEME_P)
		1631	{
		1632	int i;
		1633	uint32_t total = 0;
		1634
		1635	/* Here we scan the cells to build the free-list. */
		1636	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
		1637	{
		1638	struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
		1639	struct cell *p;
		1640	total += SCHEME_V->cell_segsize [i];
		1641
		1642	for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
		1643	{
		1644	pointer c = POINTER (p);
		1645
		1646	if (is_mark (c))
		1647	clrmark (c);
		1648	else
		1649	{
		1650	/* reclaim cell */
		1651	if (typeflag (c) != T_PAIR)
		1652	{
		1653	finalize_cell (SCHEME_A_ c);
		1654	set_typeflag (c, T_PAIR);
		1655	set_car (c, NIL);
		1656	}
		1657
		1658	++SCHEME_V->fcells;
		1659	set_cdr (c, SCHEME_V->free_cell);
		1660	SCHEME_V->free_cell = c;
		1661	}
		1662	}
		1663	}
		1664
		1665	if (SCHEME_V->gc_verbose)
		1666	{
		1667	putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n");
		1668	}
		1669	}
		1670
1607	/* garbage collection. parameter a, b is marked. */	1671	/* garbage collection. parameter a, b is marked. */
1608	static void	1672	ecb_cold static void
1609	gc (SCHEME_P_ pointer a, pointer b)	1673	gc (SCHEME_P_ pointer a, pointer b)
1610	{	1674	{
1611	pointer p;
1612	int i;	1675	int i;
1613		1676
1614	if (SCHEME_V->gc_verbose)	1677	if (SCHEME_V->gc_verbose)
1615	putstr (SCHEME_A_ "gc...");	1678	putstr (SCHEME_A_ "gc...");
1616		1679
…		…
1632	/* Mark recent objects the interpreter doesn't know about yet. */	1695	/* Mark recent objects the interpreter doesn't know about yet. */
1633	mark (car (S_SINK));	1696	mark (car (S_SINK));
1634	/* Mark any older stuff above nested C calls */	1697	/* Mark any older stuff above nested C calls */
1635	mark (SCHEME_V->c_nest);	1698	mark (SCHEME_V->c_nest);
1636		1699
		1700	#if USE_INTCACHE
		1701	/* mark intcache */
		1702	for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
		1703	if (SCHEME_V->intcache[i - INTCACHE_MIN])
		1704	mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
		1705	#endif
		1706
1637	/* mark variables a, b */	1707	/* mark variables a, b */
1638	mark (a);	1708	mark (a);
1639	mark (b);	1709	mark (b);
1640		1710
1641	/* garbage collect */	1711	/* garbage collect */
1642	clrmark (NIL);	1712	clrmark (NIL);
1643	SCHEME_V->fcells = 0;	1713	SCHEME_V->fcells = 0;
1644	SCHEME_V->free_cell = NIL;	1714	SCHEME_V->free_cell = NIL;
1645		1715
1646	/* free-list is kept sorted by address so as to maintain consecutive
1647	ranges, if possible, for use with vectors. Here we scan the cells
1648	(which are also kept sorted by address) downwards to build the
1649	free-list in sorted order.
1650	*/
1651	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1652	{
1653	p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1654
1655	while (--p >= SCHEME_V->cell_seg[i])
1656	{
1657	if (is_mark (p))
1658	clrmark (p);
1659	else
1660	{
1661	/* reclaim cell */
1662	if (typeflag (p) != T_PAIR)
1663	{
1664	finalize_cell (SCHEME_A_ p);
1665	set_typeflag (p, T_PAIR);
1666	set_car (p, NIL);
1667	}
1668
1669	++SCHEME_V->fcells;
1670	set_cdr (p, SCHEME_V->free_cell);
1671	SCHEME_V->free_cell = p;
1672	}
1673	}
1674	}
1675
1676	if (SCHEME_V->gc_verbose)	1716	if (SCHEME_V->gc_verbose)
1677	{	1717	putstr (SCHEME_A_ "freeing...");
1678	xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");
1679	}
1680	}
1681		1718
1682	static void	1719	gc_free (SCHEME_A);
1683	finalize_cell (SCHEME_P_ pointer a)
1684	{
1685	/* TODO, fast bitmap check? */
1686	if (is_string (a))
1687	free (strvalue (a));
1688	else if (is_vector (a))
1689	free (vecvalue (a));
1690	#if USE_PORTS
1691	else if (is_port (a))
1692	{
1693	if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1694	port_close (SCHEME_A_ a, port_input | port_output);
1695
1696	free (a->object.port);
1697	}
1698	#endif
1699	}	1720	}
1700		1721
1701	/* ========== Routines for Reading ========== */	1722	/* ========== Routines for Reading ========== */
1702		1723
1703	static int	1724	ecb_cold static int
1704	file_push (SCHEME_P_ const char *fname)	1725	file_push (SCHEME_P_ const char *fname)
1705	{	1726	{
1706	#if USE_PORTS	1727	#if USE_PORTS
1707	int fin;	1728	int fin;
1708		1729
…		…
1717	SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;	1738	SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1718	SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;	1739	SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1719	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;	1740	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1720	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;	1741	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1721	SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;	1742	SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1722	SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i;	1743	set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1723		1744
1724	#if SHOW_ERROR_LINE	1745	#if SHOW_ERROR_LINE
1725	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;	1746	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1726		1747
1727	if (fname)	1748	if (fname)
…		…
1734	#else	1755	#else
1735	return 1;	1756	return 1;
1736	#endif	1757	#endif
1737	}	1758	}
1738		1759
1739	static void	1760	ecb_cold static void
1740	file_pop (SCHEME_P)	1761	file_pop (SCHEME_P)
1741	{	1762	{
1742	if (SCHEME_V->file_i != 0)	1763	if (SCHEME_V->file_i != 0)
1743	{	1764	{
1744	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];	1765	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1745	#if USE_PORTS	1766	#if USE_PORTS
1746	port_close (SCHEME_A_ SCHEME_V->loadport, port_input);	1767	port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1747	#endif	1768	#endif
1748	SCHEME_V->file_i--;	1769	SCHEME_V->file_i--;
1749	SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i;	1770	set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1750	}	1771	}
1751	}	1772	}
1752		1773
1753	static int	1774	ecb_cold static int
1754	file_interactive (SCHEME_P)	1775	file_interactive (SCHEME_P)
1755	{	1776	{
1756	#if USE_PORTS	1777	#if USE_PORTS
1757	return SCHEME_V->file_i == 0	1778	return SCHEME_V->file_i == 0
1758	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO	1779	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1759	&& (SCHEME_V->inport->object.port->kind & port_file);	1780	&& (port (SCHEME_V->inport)->kind & port_file);
1760	#else	1781	#else
1761	return 0;	1782	return 0;
1762	#endif	1783	#endif
1763	}	1784	}
1764		1785
1765	#if USE_PORTS	1786	#if USE_PORTS
1766	static port *	1787	ecb_cold static port *
1767	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)	1788	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1768	{	1789	{
1769	int fd;	1790	int fd;
1770	int flags;	1791	int flags;
1771	char *rw;	1792	char *rw;
…		…
1794	# endif	1815	# endif
1795		1816
1796	return pt;	1817	return pt;
1797	}	1818	}
1798		1819
1799	static pointer	1820	ecb_cold static pointer
1800	port_from_filename (SCHEME_P_ const char *fn, int prop)	1821	port_from_filename (SCHEME_P_ const char *fn, int prop)
1801	{	1822	{
1802	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);	1823	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1803		1824
1804	if (!pt && USE_ERROR_CHECKING)	1825	if (!pt && USE_ERROR_CHECKING)
1805	return NIL;	1826	return NIL;
1806		1827
1807	return mk_port (SCHEME_A_ pt);	1828	return mk_port (SCHEME_A_ pt);
1808	}	1829	}
1809		1830
1810	static port *	1831	ecb_cold static port *
1811	port_rep_from_file (SCHEME_P_ int f, int prop)	1832	port_rep_from_file (SCHEME_P_ int f, int prop)
1812	{	1833	{
1813	port *pt = malloc (sizeof *pt);	1834	port *pt = malloc (sizeof *pt);
1814		1835
1815	if (!pt && USE_ERROR_CHECKING)	1836	if (!pt && USE_ERROR_CHECKING)
…		…
1820	pt->rep.stdio.file = f;	1841	pt->rep.stdio.file = f;
1821	pt->rep.stdio.closeit = 0;	1842	pt->rep.stdio.closeit = 0;
1822	return pt;	1843	return pt;
1823	}	1844	}
1824		1845
1825	static pointer	1846	ecb_cold static pointer
1826	port_from_file (SCHEME_P_ int f, int prop)	1847	port_from_file (SCHEME_P_ int f, int prop)
1827	{	1848	{
1828	port *pt = port_rep_from_file (SCHEME_A_ f, prop);	1849	port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1829		1850
1830	if (!pt && USE_ERROR_CHECKING)	1851	if (!pt && USE_ERROR_CHECKING)
1831	return NIL;	1852	return NIL;
1832		1853
1833	return mk_port (SCHEME_A_ pt);	1854	return mk_port (SCHEME_A_ pt);
1834	}	1855	}
1835		1856
1836	static port *	1857	ecb_cold static port *
1837	port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)	1858	port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1838	{	1859	{
1839	port *pt = malloc (sizeof (port));	1860	port *pt = malloc (sizeof (port));
1840		1861
1841	if (!pt && USE_ERROR_CHECKING)	1862	if (!pt && USE_ERROR_CHECKING)
…		…
1847	pt->rep.string.curr = start;	1868	pt->rep.string.curr = start;
1848	pt->rep.string.past_the_end = past_the_end;	1869	pt->rep.string.past_the_end = past_the_end;
1849	return pt;	1870	return pt;
1850	}	1871	}
1851		1872
1852	static pointer	1873	ecb_cold static pointer
1853	port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)	1874	port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1854	{	1875	{
1855	port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);	1876	port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1856		1877
1857	if (!pt && USE_ERROR_CHECKING)	1878	if (!pt && USE_ERROR_CHECKING)
…		…
1860	return mk_port (SCHEME_A_ pt);	1881	return mk_port (SCHEME_A_ pt);
1861	}	1882	}
1862		1883
1863	# define BLOCK_SIZE 256	1884	# define BLOCK_SIZE 256
1864		1885
1865	static port *	1886	ecb_cold static port *
1866	port_rep_from_scratch (SCHEME_P)	1887	port_rep_from_scratch (SCHEME_P)
1867	{	1888	{
1868	char *start;	1889	char *start;
1869	port *pt = malloc (sizeof (port));	1890	port *pt = malloc (sizeof (port));
1870		1891
…		…
1884	pt->rep.string.curr = start;	1905	pt->rep.string.curr = start;
1885	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;	1906	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1886	return pt;	1907	return pt;
1887	}	1908	}
1888		1909
1889	static pointer	1910	ecb_cold static pointer
1890	port_from_scratch (SCHEME_P)	1911	port_from_scratch (SCHEME_P)
1891	{	1912	{
1892	port *pt = port_rep_from_scratch (SCHEME_A);	1913	port *pt = port_rep_from_scratch (SCHEME_A);
1893		1914
1894	if (!pt && USE_ERROR_CHECKING)	1915	if (!pt && USE_ERROR_CHECKING)
1895	return NIL;	1916	return NIL;
1896		1917
1897	return mk_port (SCHEME_A_ pt);	1918	return mk_port (SCHEME_A_ pt);
1898	}	1919	}
1899		1920
1900	static void	1921	ecb_cold static void
1901	port_close (SCHEME_P_ pointer p, int flag)	1922	port_close (SCHEME_P_ pointer p, int flag)
1902	{	1923	{
1903	port *pt = p->object.port;	1924	port *pt = port (p);
1904		1925
1905	pt->kind &= ~flag;	1926	pt->kind &= ~flag;
1906		1927
1907	if ((pt->kind & (port_input | port_output)) == 0)	1928	if ((pt->kind & (port_input | port_output)) == 0)
1908	{	1929	{
…		…
1929	/* get new character from input file */	1950	/* get new character from input file */
1930	static int	1951	static int
1931	inchar (SCHEME_P)	1952	inchar (SCHEME_P)
1932	{	1953	{
1933	int c;	1954	int c;
1934	port *pt;	1955	port *pt = port (SCHEME_V->inport);
1935
1936	pt = SCHEME_V->inport->object.port;
1937		1956
1938	if (pt->kind & port_saw_EOF)	1957	if (pt->kind & port_saw_EOF)
1939	return EOF;	1958	return EOF;
1940		1959
1941	c = basic_inchar (pt);	1960	c = basic_inchar (pt);
…		…
2008	port *pt;	2027	port *pt;
2009		2028
2010	if (c == EOF)	2029	if (c == EOF)
2011	return;	2030	return;
2012		2031
2013	pt = SCHEME_V->inport->object.port;	2032	pt = port (SCHEME_V->inport);
2014	pt->unget = c;	2033	pt->unget = c;
2015	#else	2034	#else
2016	if (c == EOF)	2035	if (c == EOF)
2017	return;	2036	return;
2018		2037
2019	ungot = c;	2038	ungot = c;
2020	#endif	2039	#endif
2021	}	2040	}
2022		2041
2023	#if USE_PORTS	2042	#if USE_PORTS
2024	static int	2043	ecb_cold static int
2025	realloc_port_string (SCHEME_P_ port *p)	2044	realloc_port_string (SCHEME_P_ port *p)
2026	{	2045	{
2027	char *start = p->rep.string.start;	2046	char *start = p->rep.string.start;
2028	size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;	2047	size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2029	char *str = malloc (new_size);	2048	char *str = malloc (new_size);
…		…
2042	else	2061	else
2043	return 0;	2062	return 0;
2044	}	2063	}
2045	#endif	2064	#endif
2046		2065
2047	INTERFACE void	2066	ecb_cold INTERFACE void
2048	putstr (SCHEME_P_ const char *s)	2067	putstr (SCHEME_P_ const char *s)
2049	{	2068	{
2050	#if USE_PORTS	2069	#if USE_PORTS
2051	port *pt = SCHEME_V->outport->object.port;	2070	port *pt = port (SCHEME_V->outport);
2052		2071
2053	if (pt->kind & port_file)	2072	if (pt->kind & port_file)
2054	write (pt->rep.stdio.file, s, strlen (s));	2073	write (pt->rep.stdio.file, s, strlen (s));
2055	else	2074	else
2056	for (; *s; s++)	2075	for (; *s; s++)
…		…
2058	*pt->rep.string.curr++ = *s;	2077	*pt->rep.string.curr++ = *s;
2059	else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))	2078	else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2060	*pt->rep.string.curr++ = *s;	2079	*pt->rep.string.curr++ = *s;
2061		2080
2062	#else	2081	#else
2063	xwrstr (s);	2082	write (pt->rep.stdio.file, s, strlen (s));
2064	#endif	2083	#endif
2065	}	2084	}
2066		2085
2067	static void	2086	ecb_cold static void
2068	putchars (SCHEME_P_ const char *s, int len)	2087	putchars (SCHEME_P_ const char *s, int len)
2069	{	2088	{
2070	#if USE_PORTS	2089	#if USE_PORTS
2071	port *pt = SCHEME_V->outport->object.port;	2090	port *pt = port (SCHEME_V->outport);
2072		2091
2073	if (pt->kind & port_file)	2092	if (pt->kind & port_file)
2074	write (pt->rep.stdio.file, s, len);	2093	write (pt->rep.stdio.file, s, len);
2075	else	2094	else
2076	{	2095	{
…		…
2086	#else	2105	#else
2087	write (1, s, len);	2106	write (1, s, len);
2088	#endif	2107	#endif
2089	}	2108	}
2090		2109
2091	INTERFACE void	2110	ecb_cold INTERFACE void
2092	putcharacter (SCHEME_P_ int c)	2111	putcharacter (SCHEME_P_ int c)
2093	{	2112	{
2094	#if USE_PORTS	2113	#if USE_PORTS
2095	port *pt = SCHEME_V->outport->object.port;	2114	port *pt = port (SCHEME_V->outport);
2096		2115
2097	if (pt->kind & port_file)	2116	if (pt->kind & port_file)
2098	{	2117	{
2099	char cc = c;	2118	char cc = c;
2100	write (pt->rep.stdio.file, &cc, 1);	2119	write (pt->rep.stdio.file, &cc, 1);
…		…
2112	write (1, &c, 1);	2131	write (1, &c, 1);
2113	#endif	2132	#endif
2114	}	2133	}
2115		2134
2116	/* read characters up to delimiter, but cater to character constants */	2135	/* read characters up to delimiter, but cater to character constants */
2117	static char *	2136	ecb_cold static char *
2118	readstr_upto (SCHEME_P_ char *delim)	2137	readstr_upto (SCHEME_P_ int skip, const char *delim)
2119	{	2138	{
2120	char *p = SCHEME_V->strbuff;	2139	char *p = SCHEME_V->strbuff + skip;
2121		2140
2122	while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));	2141	while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
2123		2142
2124	if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')	2143	if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2125	*p = 0;	2144	*p = 0;
…		…
2131		2150
2132	return SCHEME_V->strbuff;	2151	return SCHEME_V->strbuff;
2133	}	2152	}
2134		2153
2135	/* read string expression "xxx...xxx" */	2154	/* read string expression "xxx...xxx" */
2136	static pointer	2155	ecb_cold static pointer
2137	readstrexp (SCHEME_P)	2156	readstrexp (SCHEME_P_ char delim)
2138	{	2157	{
2139	char *p = SCHEME_V->strbuff;	2158	char *p = SCHEME_V->strbuff;
2140	int c;	2159	int c;
2141	int c1 = 0;	2160	int c1 = 0;
2142	enum
2143	{ st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;	2161	enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
2144		2162
2145	for (;;)	2163	for (;;)
2146	{	2164	{
2147	c = inchar (SCHEME_A);	2165	c = inchar (SCHEME_A);
2148		2166
…		…
2150	return S_F;	2168	return S_F;
2151		2169
2152	switch (state)	2170	switch (state)
2153	{	2171	{
2154	case st_ok:	2172	case st_ok:
2155	switch (c)	2173	if (ecb_expect_false (c == delim))
2156	{
2157	case '\\':
2158	state = st_bsl;
2159	break;
2160
2161	case '"':
2162	*p = 0;
2163	return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);	2174	return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
2164		2175
2165	default:	2176	if (ecb_expect_false (c == '\\'))
		2177	state = st_bsl;
		2178	else
2166	*p++ = c;	2179	*p++ = c;
2167	break;
2168	}
2169		2180
2170	break;	2181	break;
2171		2182
2172	case st_bsl:	2183	case st_bsl:
2173	switch (c)	2184	switch (c)
…		…
2182	case '7':	2193	case '7':
2183	state = st_oct1;	2194	state = st_oct1;
2184	c1 = c - '0';	2195	c1 = c - '0';
2185	break;	2196	break;
2186		2197
		2198	case 'a': *p++ = '\a'; state = st_ok; break;
		2199	case 'n': *p++ = '\n'; state = st_ok; break;
		2200	case 'r': *p++ = '\r'; state = st_ok; break;
		2201	case 't': *p++ = '\t'; state = st_ok; break;
		2202
		2203	//TODO: \whitespace eol whitespace
		2204
		2205	//TODO: x should end in ;, not two-digit hex
2187	case 'x':	2206	case 'x':
2188	case 'X':	2207	case 'X':
2189	state = st_x1;	2208	state = st_x1;
2190	c1 = 0;	2209	c1 = 0;
2191	break;	2210	break;
2192		2211
2193	case 'n':
2194	*p++ = '\n';
2195	state = st_ok;
2196	break;
2197
2198	case 't':
2199	*p++ = '\t';
2200	state = st_ok;
2201	break;
2202
2203	case 'r':
2204	*p++ = '\r';
2205	state = st_ok;
2206	break;
2207
2208	case '"':
2209	*p++ = '"';
2210	state = st_ok;
2211	break;
2212
2213	default:	2212	default:
2214	*p++ = c;	2213	*p++ = c;
2215	state = st_ok;	2214	state = st_ok;
2216	break;	2215	break;
2217	}	2216	}
2218		2217
2219	break;	2218	break;
2220		2219
2221	case st_x1:	2220	case st_x1:
2222	case st_x2:	2221	case st_x2:
2223	c = toupper (c);	2222	c = tolower (c);
2224		2223
2225	if (c >= '0' && c <= 'F')	2224	if (c >= '0' && c <= '9')
2226	{
2227	if (c <= '9')
2228	c1 = (c1 << 4) + c - '0';	2225	c1 = (c1 << 4) + c - '0';
2229	else	2226	else if (c >= 'a' && c <= 'f')
2230	c1 = (c1 << 4) + c - 'A' + 10;	2227	c1 = (c1 << 4) + c - 'a' + 10;
2231
2232	if (state == st_x1)
2233	state = st_x2;
2234	else
2235	{
2236	*p++ = c1;
2237	state = st_ok;
2238	}
2239	}
2240	else	2228	else
2241	return S_F;	2229	return S_F;
		2230
		2231	if (state == st_x1)
		2232	state = st_x2;
		2233	else
		2234	{
		2235	*p++ = c1;
		2236	state = st_ok;
		2237	}
2242		2238
2243	break;	2239	break;
2244		2240
2245	case st_oct1:	2241	case st_oct1:
2246	case st_oct2:	2242	case st_oct2:
…		…
2250	backchar (SCHEME_A_ c);	2246	backchar (SCHEME_A_ c);
2251	state = st_ok;	2247	state = st_ok;
2252	}	2248	}
2253	else	2249	else
2254	{	2250	{
2255	if (state == st_oct2 && c1 >= 32)	2251	if (state == st_oct2 && c1 >= ' ')
2256	return S_F;	2252	return S_F;
2257		2253
2258	c1 = (c1 << 3) + (c - '0');	2254	c1 = (c1 << 3) + (c - '0');
2259		2255
2260	if (state == st_oct1)	2256	if (state == st_oct1)
…		…
2265	state = st_ok;	2261	state = st_ok;
2266	}	2262	}
2267	}	2263	}
2268		2264
2269	break;	2265	break;
2270
2271	}	2266	}
2272	}	2267	}
2273	}	2268	}
2274		2269
2275	/* check c is in chars */	2270	/* check c is in chars */
2276	ecb_inline int	2271	ecb_cold int
2277	is_one_of (char *s, int c)	2272	is_one_of (const char *s, int c)
2278	{	2273	{
2279	if (c == EOF)
2280	return 1;
2281
2282	return !!strchr (s, c);	2274	return c == EOF || !!strchr (s, c);
2283	}	2275	}
2284		2276
2285	/* skip white characters */	2277	/* skip white characters */
2286	ecb_inline int	2278	ecb_cold int
2287	skipspace (SCHEME_P)	2279	skipspace (SCHEME_P)
2288	{	2280	{
2289	int c, curr_line = 0;	2281	int c, curr_line = 0;
2290		2282
2291	do	2283	do
2292	{	2284	{
2293	c = inchar (SCHEME_A);	2285	c = inchar (SCHEME_A);
		2286
2294	#if SHOW_ERROR_LINE	2287	#if SHOW_ERROR_LINE
2295	if (c == '\n')	2288	if (ecb_expect_false (c == '\n'))
2296	curr_line++;	2289	curr_line++;
2297	#endif	2290	#endif
		2291
		2292	if (ecb_expect_false (c == EOF))
		2293	return c;
2298	}	2294	}
2299	while (c == ' ' || c == '\n' || c == '\r' || c == '\t');	2295	while (is_one_of (WHITESPACE, c));
2300		2296
2301	/* record it */	2297	/* record it */
2302	#if SHOW_ERROR_LINE	2298	#if SHOW_ERROR_LINE
2303	if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)	2299	if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2304	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;	2300	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
2305	#endif	2301	#endif
2306		2302
2307	if (c != EOF)
2308	{
2309	backchar (SCHEME_A_ c);	2303	backchar (SCHEME_A_ c);
2310	return 1;	2304	return 1;
2311	}
2312	else
2313	return EOF;
2314	}	2305	}
2315		2306
2316	/* get token */	2307	/* get token */
2317	static int	2308	ecb_cold static int
2318	token (SCHEME_P)	2309	token (SCHEME_P)
2319	{	2310	{
2320	int c = skipspace (SCHEME_A);	2311	int c = skipspace (SCHEME_A);
2321		2312
2322	if (c == EOF)	2313	if (c == EOF)
…		…
2334	return TOK_RPAREN;	2325	return TOK_RPAREN;
2335		2326
2336	case '.':	2327	case '.':
2337	c = inchar (SCHEME_A);	2328	c = inchar (SCHEME_A);
2338		2329
2339	if (is_one_of (" \n\t", c))	2330	if (is_one_of (WHITESPACE, c))
2340	return TOK_DOT;	2331	return TOK_DOT;
2341	else	2332	else
2342	{	2333	{
2343	//TODO: ungetc twice in a row is not supported in C
2344	backchar (SCHEME_A_ c);	2334	backchar (SCHEME_A_ c);
2345	backchar (SCHEME_A_ '.');
2346	return TOK_ATOM;	2335	return TOK_DOTATOM;
2347	}	2336	}
		2337
		2338	case '|':
		2339	return TOK_STRATOM;
2348		2340
2349	case '\'':	2341	case '\'':
2350	return TOK_QUOTE;	2342	return TOK_QUOTE;
2351		2343
2352	case ';':	2344	case ';':
…		…
2419	}	2411	}
2420		2412
2421	/* ========== Routines for Printing ========== */	2413	/* ========== Routines for Printing ========== */
2422	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)	2414	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2423		2415
2424	static void	2416	ecb_cold static void
2425	printslashstring (SCHEME_P_ char *p, int len)	2417	printslashstring (SCHEME_P_ char *p, int len)
2426	{	2418	{
2427	int i;	2419	int i;
2428	unsigned char *s = (unsigned char *) p;	2420	unsigned char *s = (unsigned char *) p;
2429		2421
…		…
2484	}	2476	}
2485		2477
2486	putcharacter (SCHEME_A_ '"');	2478	putcharacter (SCHEME_A_ '"');
2487	}	2479	}
2488		2480
2489
2490	/* print atoms */	2481	/* print atoms */
2491	static void	2482	ecb_cold static void
2492	printatom (SCHEME_P_ pointer l, int f)	2483	printatom (SCHEME_P_ pointer l, int f)
2493	{	2484	{
2494	char *p;	2485	char *p;
2495	int len;	2486	int len;
2496		2487
2497	atom2str (SCHEME_A_ l, f, &p, &len);	2488	atom2str (SCHEME_A_ l, f, &p, &len);
2498	putchars (SCHEME_A_ p, len);	2489	putchars (SCHEME_A_ p, len);
2499	}	2490	}
2500		2491
2501
2502	/* Uses internal buffer unless string pointer is already available */	2492	/* Uses internal buffer unless string pointer is already available */
2503	static void	2493	ecb_cold static void
2504	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)	2494	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2505	{	2495	{
2506	char *p;	2496	char *p;
2507		2497
2508	if (l == NIL)	2498	if (l == NIL)
…		…
2666	#endif	2656	#endif
2667	}	2657	}
2668	else if (is_continuation (l))	2658	else if (is_continuation (l))
2669	p = "#<CONTINUATION>";	2659	p = "#<CONTINUATION>";
2670	else	2660	else
		2661	{
		2662	#if USE_PRINTF
		2663	p = SCHEME_V->strbuff;
		2664	snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
		2665	#else
2671	p = "#<ERROR>";	2666	p = "#<ERROR>";
		2667	#endif
		2668	}
2672		2669
2673	*pp = p;	2670	*pp = p;
2674	*plen = strlen (p);	2671	*plen = strlen (p);
2675	}	2672	}
2676		2673
…		…
2708	return car (d);	2705	return car (d);
2709		2706
2710	p = cons (car (d), cdr (d));	2707	p = cons (car (d), cdr (d));
2711	q = p;	2708	q = p;
2712		2709
2713	while (cdr (cdr (p)) != NIL)	2710	while (cddr (p) != NIL)
2714	{	2711	{
2715	d = cons (car (p), cdr (p));	2712	d = cons (car (p), cdr (p));
2716		2713
2717	if (cdr (cdr (p)) != NIL)	2714	if (cddr (p) != NIL)
2718	p = cdr (d);	2715	p = cdr (d);
2719	}	2716	}
2720		2717
2721	set_cdr (p, car (cdr (p)));	2718	set_cdr (p, cadr (p));
2722	return q;	2719	return q;
2723	}	2720	}
2724		2721
2725	/* reverse list -- produce new list */	2722	/* reverse list -- produce new list */
2726	static pointer	2723	ecb_hot static pointer
2727	reverse (SCHEME_P_ pointer a)	2724	reverse (SCHEME_P_ pointer a)
2728	{	2725	{
2729	/* a must be checked by gc */	2726	/* a must be checked by gc */
2730	pointer p = NIL;	2727	pointer p = NIL;
2731		2728
…		…
2734		2731
2735	return p;	2732	return p;
2736	}	2733	}
2737		2734
2738	/* reverse list --- in-place */	2735	/* reverse list --- in-place */
2739	static pointer	2736	ecb_hot static pointer
2740	reverse_in_place (SCHEME_P_ pointer term, pointer list)	2737	reverse_in_place (SCHEME_P_ pointer term, pointer list)
2741	{	2738	{
2742	pointer result = term;	2739	pointer result = term;
2743	pointer p = list;	2740	pointer p = list;
2744		2741
…		…
2752		2749
2753	return result;	2750	return result;
2754	}	2751	}
2755		2752
2756	/* append list -- produce new list (in reverse order) */	2753	/* append list -- produce new list (in reverse order) */
2757	static pointer	2754	ecb_hot static pointer
2758	revappend (SCHEME_P_ pointer a, pointer b)	2755	revappend (SCHEME_P_ pointer a, pointer b)
2759	{	2756	{
2760	pointer result = a;	2757	pointer result = a;
2761	pointer p = b;	2758	pointer p = b;
2762		2759
…		…
2771		2768
2772	return S_F; /* signal an error */	2769	return S_F; /* signal an error */
2773	}	2770	}
2774		2771
2775	/* equivalence of atoms */	2772	/* equivalence of atoms */
2776	int	2773	ecb_hot int
2777	eqv (pointer a, pointer b)	2774	eqv (pointer a, pointer b)
2778	{	2775	{
2779	if (is_string (a))	2776	if (is_string (a))
2780	{	2777	{
2781	if (is_string (b))	2778	if (is_string (b))
…		…
2875	}	2872	}
2876	else	2873	else
2877	set_car (env, immutable_cons (slot, car (env)));	2874	set_car (env, immutable_cons (slot, car (env)));
2878	}	2875	}
2879		2876
2880	static pointer	2877	ecb_hot static pointer
2881	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)	2878	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2882	{	2879	{
2883	pointer x, y;	2880	pointer x, y;
2884		2881
2885	for (x = env; x != NIL; x = cdr (x))	2882	for (x = env; x != NIL; x = cdr (x))
…		…
2906	return NIL;	2903	return NIL;
2907	}	2904	}
2908		2905
2909	#else /* USE_ALIST_ENV */	2906	#else /* USE_ALIST_ENV */
2910		2907
2911	ecb_inline void	2908	static void
2912	new_frame_in_env (SCHEME_P_ pointer old_env)	2909	new_frame_in_env (SCHEME_P_ pointer old_env)
2913	{	2910	{
2914	SCHEME_V->envir = immutable_cons (NIL, old_env);	2911	SCHEME_V->envir = immutable_cons (NIL, old_env);
2915	setenvironment (SCHEME_V->envir);	2912	setenvironment (SCHEME_V->envir);
2916	}	2913	}
2917		2914
2918	ecb_inline void	2915	static void
2919	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2916	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2920	{	2917	{
2921	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2918	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2922	}	2919	}
2923		2920
2924	static pointer	2921	ecb_hot static pointer
2925	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)	2922	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2926	{	2923	{
2927	pointer x, y;	2924	pointer x, y;
2928		2925
2929	for (x = env; x != NIL; x = cdr (x))	2926	for (x = env; x != NIL; x = cdr (x))
…		…
2943	return NIL;	2940	return NIL;
2944	}	2941	}
2945		2942
2946	#endif /* USE_ALIST_ENV else */	2943	#endif /* USE_ALIST_ENV else */
2947		2944
2948	ecb_inline void	2945	static void
2949	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2946	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2950	{	2947	{
		2948	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2951	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);	2949	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2952	}	2950	}
2953		2951
2954	ecb_inline void	2952	static void
2955	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2953	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2956	{	2954	{
2957	set_cdr (slot, value);	2955	set_cdr (slot, value);
2958	}	2956	}
2959		2957
2960	ecb_inline pointer	2958	static pointer
2961	slot_value_in_env (pointer slot)	2959	slot_value_in_env (pointer slot)
2962	{	2960	{
2963	return cdr (slot);	2961	return cdr (slot);
2964	}	2962	}
2965		2963
2966	/* ========== Evaluation Cycle ========== */	2964	/* ========== Evaluation Cycle ========== */
2967		2965
2968	static int	2966	ecb_cold static int
2969	xError_1 (SCHEME_P_ const char *s, pointer a)	2967	xError_1 (SCHEME_P_ const char *s, pointer a)
2970	{	2968	{
2971	#if USE_ERROR_HOOK	2969	#if USE_ERROR_HOOK
2972	pointer x;	2970	pointer x;
2973	pointer hdl = SCHEME_V->ERROR_HOOK;	2971	pointer hdl = SCHEME_V->ERROR_HOOK;
…		…
3049	pointer code;	3047	pointer code;
3050	};	3048	};
3051		3049
3052	# define STACK_GROWTH 3	3050	# define STACK_GROWTH 3
3053		3051
3054	static void	3052	ecb_hot static void
3055	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)	3053	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3056	{	3054	{
3057	int nframes = (uintptr_t)SCHEME_V->dump;	3055	int nframes = (uintptr_t)SCHEME_V->dump;
3058	struct dump_stack_frame *next_frame;	3056	struct dump_stack_frame *next_frame;
3059		3057
3060	/* enough room for the next frame? */	3058	/* enough room for the next frame? */
3061	if (nframes >= SCHEME_V->dump_size)	3059	if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3062	{	3060	{
3063	SCHEME_V->dump_size += STACK_GROWTH;	3061	SCHEME_V->dump_size += STACK_GROWTH;
3064	SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);	3062	SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3065	}	3063	}
3066		3064
…		…
3072	next_frame->code = code;	3070	next_frame->code = code;
3073		3071
3074	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3072	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3075	}	3073	}
3076		3074
3077	static int	3075	static ecb_hot int
3078	xs_return (SCHEME_P_ pointer a)	3076	xs_return (SCHEME_P_ pointer a)
3079	{	3077	{
3080	int nframes = (uintptr_t)SCHEME_V->dump;	3078	int nframes = (uintptr_t)SCHEME_V->dump;
3081	struct dump_stack_frame *frame;	3079	struct dump_stack_frame *frame;
3082		3080
…		…
3093	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3091	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3094		3092
3095	return 0;	3093	return 0;
3096	}	3094	}
3097		3095
3098	ecb_inline void	3096	ecb_cold void
3099	dump_stack_reset (SCHEME_P)	3097	dump_stack_reset (SCHEME_P)
3100	{	3098	{
3101	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */	3099	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3102	SCHEME_V->dump = (pointer)+0;	3100	SCHEME_V->dump = (pointer)+0;
3103	}	3101	}
3104		3102
3105	ecb_inline void	3103	ecb_cold void
3106	dump_stack_initialize (SCHEME_P)	3104	dump_stack_initialize (SCHEME_P)
3107	{	3105	{
3108	SCHEME_V->dump_size = 0;	3106	SCHEME_V->dump_size = 0;
3109	SCHEME_V->dump_base = 0;	3107	SCHEME_V->dump_base = 0;
3110	dump_stack_reset (SCHEME_A);	3108	dump_stack_reset (SCHEME_A);
3111	}	3109	}
3112		3110
3113	static void	3111	ecb_cold static void
3114	dump_stack_free (SCHEME_P)	3112	dump_stack_free (SCHEME_P)
3115	{	3113	{
3116	free (SCHEME_V->dump_base);	3114	free (SCHEME_V->dump_base);
3117	SCHEME_V->dump_base = 0;	3115	SCHEME_V->dump_base = 0;
3118	SCHEME_V->dump = (pointer)0;	3116	SCHEME_V->dump = (pointer)0;
3119	SCHEME_V->dump_size = 0;	3117	SCHEME_V->dump_size = 0;
3120	}	3118	}
3121		3119
3122	static void	3120	ecb_cold static void
3123	dump_stack_mark (SCHEME_P)	3121	dump_stack_mark (SCHEME_P)
3124	{	3122	{
3125	int nframes = (uintptr_t)SCHEME_V->dump;	3123	int nframes = (uintptr_t)SCHEME_V->dump;
3126	int i;	3124	int i;
3127		3125
…		…
3133	mark (frame->envir);	3131	mark (frame->envir);
3134	mark (frame->code);	3132	mark (frame->code);
3135	}	3133	}
3136	}	3134	}
3137		3135
3138	static pointer	3136	ecb_cold static pointer
3139	ss_get_cont (SCHEME_P)	3137	ss_get_cont (SCHEME_P)
3140	{	3138	{
3141	int nframes = (uintptr_t)SCHEME_V->dump;	3139	int nframes = (uintptr_t)SCHEME_V->dump;
3142	int i;	3140	int i;
3143		3141
…		…
3155	}	3153	}
3156		3154
3157	return cont;	3155	return cont;
3158	}	3156	}
3159		3157
3160	static void	3158	ecb_cold static void
3161	ss_set_cont (SCHEME_P_ pointer cont)	3159	ss_set_cont (SCHEME_P_ pointer cont)
3162	{	3160	{
3163	int i = 0;	3161	int i = 0;
3164	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3162	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3165		3163
…		…
3177	SCHEME_V->dump = (pointer)(uintptr_t)i;	3175	SCHEME_V->dump = (pointer)(uintptr_t)i;
3178	}	3176	}
3179		3177
3180	#else	3178	#else
3181		3179
3182	ecb_inline void	3180	ecb_cold void
3183	dump_stack_reset (SCHEME_P)	3181	dump_stack_reset (SCHEME_P)
3184	{	3182	{
3185	SCHEME_V->dump = NIL;	3183	SCHEME_V->dump = NIL;
3186	}	3184	}
3187		3185
3188	ecb_inline void	3186	ecb_cold void
3189	dump_stack_initialize (SCHEME_P)	3187	dump_stack_initialize (SCHEME_P)
3190	{	3188	{
3191	dump_stack_reset (SCHEME_A);	3189	dump_stack_reset (SCHEME_A);
3192	}	3190	}
3193		3191
3194	static void	3192	ecb_cold static void
3195	dump_stack_free (SCHEME_P)	3193	dump_stack_free (SCHEME_P)
3196	{	3194	{
3197	SCHEME_V->dump = NIL;	3195	SCHEME_V->dump = NIL;
3198	}	3196	}
3199		3197
3200	static int	3198	ecb_hot static int
3201	xs_return (SCHEME_P_ pointer a)	3199	xs_return (SCHEME_P_ pointer a)
3202	{	3200	{
3203	pointer dump = SCHEME_V->dump;	3201	pointer dump = SCHEME_V->dump;
3204		3202
3205	SCHEME_V->value = a;	3203	SCHEME_V->value = a;
…		…
3215	SCHEME_V->dump = dump;	3213	SCHEME_V->dump = dump;
3216		3214
3217	return 0;	3215	return 0;
3218	}	3216	}
3219		3217
3220	static void	3218	ecb_hot static void
3221	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)	3219	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3222	{	3220	{
3223	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),	3221	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3224	cons (args,	3222	cons (args,
3225	cons (SCHEME_V->envir,	3223	cons (SCHEME_V->envir,
3226	cons (code,	3224	cons (code,
3227	SCHEME_V->dump))));	3225	SCHEME_V->dump))));
3228	}	3226	}
3229		3227
3230	static void	3228	ecb_cold static void
3231	dump_stack_mark (SCHEME_P)	3229	dump_stack_mark (SCHEME_P)
3232	{	3230	{
3233	mark (SCHEME_V->dump);	3231	mark (SCHEME_V->dump);
3234	}	3232	}
3235		3233
3236	static pointer	3234	ecb_cold static pointer
3237	ss_get_cont (SCHEME_P)	3235	ss_get_cont (SCHEME_P)
3238	{	3236	{
3239	return SCHEME_V->dump;	3237	return SCHEME_V->dump;
3240	}	3238	}
3241		3239
3242	static void	3240	ecb_cold static void
3243	ss_set_cont (SCHEME_P_ pointer cont)	3241	ss_set_cont (SCHEME_P_ pointer cont)
3244	{	3242	{
3245	SCHEME_V->dump = cont;	3243	SCHEME_V->dump = cont;
3246	}	3244	}
3247		3245
3248	#endif	3246	#endif
3249		3247
3250	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3248	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3251		3249
		3250	#if EXPERIMENT
3252	static int	3251	static int
		3252	debug (SCHEME_P_ int indent, pointer x)
		3253	{
		3254	int c;
		3255
		3256	if (is_syntax (x))
		3257	{
		3258	printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
		3259	return 8 + 8;
		3260	}
		3261
		3262	if (x == NIL)
		3263	{
		3264	printf ("%*sNIL\n", indent, "");
		3265	return 3;
		3266	}
		3267
		3268	switch (type (x))
		3269	{
		3270	case T_INTEGER:
		3271	printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
		3272	return 32+8;
		3273
		3274	case T_SYMBOL:
		3275	printf ("%*sS<%s>\n", indent, "", symname (x));
		3276	return 24+8;
		3277
		3278	case T_CLOSURE:
		3279	printf ("%*sS<%s>\n", indent, "", "closure");
		3280	debug (SCHEME_A_ indent + 3, cdr(x));
		3281	return 32 + debug (SCHEME_A_ indent + 3, car (x));
		3282
		3283	case T_PAIR:
		3284	printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
		3285	c = debug (SCHEME_A_ indent + 3, car (x));
		3286	c += debug (SCHEME_A_ indent + 3, cdr (x));
		3287	return c + 1;
		3288
		3289	case T_PORT:
		3290	printf ("%*sS<%s>\n", indent, "", "port");
		3291	return 24+8;
		3292
		3293	case T_VECTOR:
		3294	printf ("%*sS<%s>\n", indent, "", "vector");
		3295	return 24+8;
		3296
		3297	case T_ENVIRONMENT:
		3298	printf ("%*sS<%s>\n", indent, "", "environment");
		3299	return 0 + debug (SCHEME_A_ indent + 3, car (x));
		3300
		3301	default:
		3302	printf ("unhandled type %d\n", type (x));
		3303	break;
		3304	}
		3305	}
		3306	#endif
		3307
		3308	/* syntax, eval, core, ... */
		3309	ecb_hot static int
3253	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3310	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3254	{	3311	{
3255	pointer args = SCHEME_V->args;	3312	pointer args = SCHEME_V->args;
3256	pointer x, y;	3313	pointer x, y;
3257		3314
3258	switch (op)	3315	switch (op)
3259	{	3316	{
		3317	#if EXPERIMENT //D
		3318	case OP_DEBUG:
		3319	printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
		3320	printf ("\n");
		3321	s_return (S_T);
		3322	#endif
3260	case OP_LOAD: /* load */	3323	case OP_LOAD: /* load */
3261	if (file_interactive (SCHEME_A))	3324	if (file_interactive (SCHEME_A))
3262	{	3325	{
3263	xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");	3326	putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
3264	//D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));	3327	//D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3265	}	3328	}
3266		3329
3267	if (!file_push (SCHEME_A_ strvalue (car (args))))	3330	if (!file_push (SCHEME_A_ strvalue (car (args))))
3268	Error_1 ("unable to open", car (args));	3331	Error_1 ("unable to open", car (args));
3269	else	3332	else
…		…
3273	}	3336	}
3274		3337
3275	case OP_T0LVL: /* top level */	3338	case OP_T0LVL: /* top level */
3276		3339
3277	/* If we reached the end of file, this loop is done. */	3340	/* If we reached the end of file, this loop is done. */
3278	if (SCHEME_V->loadport->object.port->kind & port_saw_EOF)	3341	if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3279	{	3342	{
3280	if (SCHEME_V->file_i == 0)	3343	if (SCHEME_V->file_i == 0)
3281	{	3344	{
3282	SCHEME_V->args = NIL;	3345	SCHEME_V->args = NIL;
3283	s_goto (OP_QUIT);	3346	s_goto (OP_QUIT);
…		…
3361	#endif	3424	#endif
3362	if (is_symbol (SCHEME_V->code)) /* symbol */	3425	if (is_symbol (SCHEME_V->code)) /* symbol */
3363	{	3426	{
3364	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);	3427	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3365		3428
3366	if (x != NIL)	3429	if (x == NIL)
3367	s_return (slot_value_in_env (x));
3368	else
3369	Error_1 ("eval: unbound variable:", SCHEME_V->code);	3430	Error_1 ("eval: unbound variable:", SCHEME_V->code);
		3431
		3432	s_return (slot_value_in_env (x));
3370	}	3433	}
3371	else if (is_pair (SCHEME_V->code))	3434	else if (is_pair (SCHEME_V->code))
3372	{	3435	{
3373	x = car (SCHEME_V->code);	3436	x = car (SCHEME_V->code);
3374		3437
…		…
3387	}	3450	}
3388	else	3451	else
3389	s_return (SCHEME_V->code);	3452	s_return (SCHEME_V->code);
3390		3453
3391	case OP_E0ARGS: /* eval arguments */	3454	case OP_E0ARGS: /* eval arguments */
3392	if (is_macro (SCHEME_V->value)) /* macro expansion */	3455	if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3393	{	3456	{
3394	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);	3457	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3395	SCHEME_V->args = cons (SCHEME_V->code, NIL);	3458	SCHEME_V->args = cons (SCHEME_V->code, NIL);
3396	SCHEME_V->code = SCHEME_V->value;	3459	SCHEME_V->code = SCHEME_V->value;
3397	s_goto (OP_APPLY);	3460	s_goto (OP_APPLY);
…		…
3451	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */	3514	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3452	else if (is_foreign (SCHEME_V->code))	3515	else if (is_foreign (SCHEME_V->code))
3453	{	3516	{
3454	/* Keep nested calls from GC'ing the arglist */	3517	/* Keep nested calls from GC'ing the arglist */
3455	push_recent_alloc (SCHEME_A_ args, NIL);	3518	push_recent_alloc (SCHEME_A_ args, NIL);
3456	x = SCHEME_V->code->object.ff (SCHEME_A_ args);	3519	x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3457		3520
3458	s_return (x);	3521	s_return (x);
3459	}	3522	}
3460	else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */	3523	else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3461	{	3524	{
…		…
3498		3561
3499	case OP_DOMACRO: /* do macro */	3562	case OP_DOMACRO: /* do macro */
3500	SCHEME_V->code = SCHEME_V->value;	3563	SCHEME_V->code = SCHEME_V->value;
3501	s_goto (OP_EVAL);	3564	s_goto (OP_EVAL);
3502		3565
3503	#if 1
3504
3505	case OP_LAMBDA: /* lambda */	3566	case OP_LAMBDA: /* lambda */
3506	/* If the hook is defined, apply it to SCHEME_V->code, otherwise	3567	/* If the hook is defined, apply it to SCHEME_V->code, otherwise
3507	set SCHEME_V->value fall thru */	3568	set SCHEME_V->value fall thru */
3508	{	3569	{
3509	pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1);	3570	pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1);
…		…
3515	SCHEME_V->code = slot_value_in_env (f);	3576	SCHEME_V->code = slot_value_in_env (f);
3516	s_goto (OP_APPLY);	3577	s_goto (OP_APPLY);
3517	}	3578	}
3518		3579
3519	SCHEME_V->value = SCHEME_V->code;	3580	SCHEME_V->value = SCHEME_V->code;
3520	/* Fallthru */
3521	}	3581	}
		3582	/* Fallthru */
3522		3583
3523	case OP_LAMBDA1:	3584	case OP_LAMBDA1:
3524	s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));	3585	s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));
3525
3526	#else
3527
3528	case OP_LAMBDA: /* lambda */
3529	s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3530
3531	#endif
3532		3586
3533	case OP_MKCLOSURE: /* make-closure */	3587	case OP_MKCLOSURE: /* make-closure */
3534	x = car (args);	3588	x = car (args);
3535		3589
3536	if (car (x) == SCHEME_V->LAMBDA)	3590	if (car (x) == SCHEME_V->LAMBDA)
…		…
3946	}	4000	}
3947		4001
3948	if (USE_ERROR_CHECKING) abort ();	4002	if (USE_ERROR_CHECKING) abort ();
3949	}	4003	}
3950		4004
3951	static int	4005	/* math, cxr */
		4006	ecb_hot static int
3952	opexe_1 (SCHEME_P_ enum scheme_opcodes op)	4007	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3953	{	4008	{
3954	pointer args = SCHEME_V->args;	4009	pointer args = SCHEME_V->args;
3955	pointer x = car (args);	4010	pointer x = car (args);
3956	num v;	4011	num v;
3957		4012
3958	switch (op)	4013	switch (op)
3959	{	4014	{
3960	#if USE_MATH	4015	#if USE_MATH
3961	case OP_INEX2EX: /* inexact->exact */	4016	case OP_INEX2EX: /* inexact->exact */
3962	{
3963	if (is_integer (x))	4017	if (!is_integer (x))
3964	s_return (x);	4018	{
3965
3966	RVALUE r = rvalue_unchecked (x);	4019	RVALUE r = rvalue_unchecked (x);
3967		4020
3968	if (r == (RVALUE)(IVALUE)r)	4021	if (r == (RVALUE)(IVALUE)r)
3969	s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x)));	4022	x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
3970	else	4023	else
3971	Error_1 ("inexact->exact: not integral:", x);	4024	Error_1 ("inexact->exact: not integral:", x);
3972	}	4025	}
3973		4026
		4027	s_return (x);
		4028
		4029	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
		4030	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
		4031	case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
		4032	case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
		4033
		4034	case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
3974	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));	4035	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
3975	case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))));	4036	case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
		4037	/ (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
3976	case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));	4038	case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
3977	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));	4039	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
3978	case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));	4040	case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
3979	case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));	4041	case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
3980	case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));	4042	case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
3981		4043
3982	case OP_ATAN:	4044	case OP_ATAN:
		4045	s_return (mk_real (SCHEME_A_
3983	if (cdr (args) == NIL)	4046	cdr (args) == NIL
3984	s_return (mk_real (SCHEME_A_ atan (rvalue (x))));	4047	? atan (rvalue (x))
3985	else	4048	: atan2 (rvalue (x), rvalue (cadr (args)))));
3986	{
3987	pointer y = cadr (args);
3988	s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
3989	}
3990
3991	case OP_SQRT:
3992	s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
3993		4049
3994	case OP_EXPT:	4050	case OP_EXPT:
3995	{	4051	{
3996	RVALUE result;	4052	RVALUE result;
3997	int real_result = 1;	4053	int real_result = 1;
…		…
4020	if (real_result)	4076	if (real_result)
4021	s_return (mk_real (SCHEME_A_ result));	4077	s_return (mk_real (SCHEME_A_ result));
4022	else	4078	else
4023	s_return (mk_integer (SCHEME_A_ result));	4079	s_return (mk_integer (SCHEME_A_ result));
4024	}	4080	}
4025
4026	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4027	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4028
4029	case OP_TRUNCATE:
4030	{
4031	RVALUE n = rvalue (x);
4032	s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4033	}
4034
4035	case OP_ROUND:
4036	if (is_integer (x))
4037	s_return (x);
4038
4039	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4040	#endif	4081	#endif
4041		4082
4042	case OP_ADD: /* + */	4083	case OP_ADD: /* + */
4043	v = num_zero;	4084	v = num_zero;
4044		4085
…		…
4132	else	4173	else
4133	Error_0 ("modulo: division by zero");	4174	Error_0 ("modulo: division by zero");
4134		4175
4135	s_return (mk_number (SCHEME_A_ v));	4176	s_return (mk_number (SCHEME_A_ v));
4136		4177
4137	case OP_CAR: /* car */	4178	/* the compiler will optimize this mess... */
4138	s_return (caar (args));	4179	case OP_CAR: op_car: s_return (car (x));
4139		4180	case OP_CDR: op_cdr: s_return (cdr (x));
4140	case OP_CDR: /* cdr */	4181	case OP_CAAR: op_caar: x = car (x); goto op_car;
4141	s_return (cdar (args));	4182	case OP_CADR: op_cadr: x = cdr (x); goto op_car;
		4183	case OP_CDAR: op_cdar: x = car (x); goto op_cdr;
		4184	case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr;
		4185	case OP_CAAAR: op_caaar: x = car (x); goto op_caar;
		4186	case OP_CAADR: op_caadr: x = cdr (x); goto op_caar;
		4187	case OP_CADAR: op_cadar: x = car (x); goto op_cadr;
		4188	case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr;
		4189	case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar;
		4190	case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar;
		4191	case OP_CDDAR: op_cddar: x = car (x); goto op_cddr;
		4192	case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr;
		4193	case OP_CAAAAR: x = car (x); goto op_caaar;
		4194	case OP_CAAADR: x = cdr (x); goto op_caaar;
		4195	case OP_CAADAR: x = car (x); goto op_caadr;
		4196	case OP_CAADDR: x = cdr (x); goto op_caadr;
		4197	case OP_CADAAR: x = car (x); goto op_cadar;
		4198	case OP_CADADR: x = cdr (x); goto op_cadar;
		4199	case OP_CADDAR: x = car (x); goto op_caddr;
		4200	case OP_CADDDR: x = cdr (x); goto op_caddr;
		4201	case OP_CDAAAR: x = car (x); goto op_cdaar;
		4202	case OP_CDAADR: x = cdr (x); goto op_cdaar;
		4203	case OP_CDADAR: x = car (x); goto op_cdadr;
		4204	case OP_CDADDR: x = cdr (x); goto op_cdadr;
		4205	case OP_CDDAAR: x = car (x); goto op_cddar;
		4206	case OP_CDDADR: x = cdr (x); goto op_cddar;
		4207	case OP_CDDDAR: x = car (x); goto op_cdddr;
		4208	case OP_CDDDDR: x = cdr (x); goto op_cdddr;
4142		4209
4143	case OP_CONS: /* cons */	4210	case OP_CONS: /* cons */
4144	set_cdr (args, cadr (args));	4211	set_cdr (args, cadr (args));
4145	s_return (args);	4212	s_return (args);
4146		4213
…		…
4320	memcpy (pos, strvalue (car (x)), strlength (car (x)));	4387	memcpy (pos, strvalue (car (x)), strlength (car (x)));
4321		4388
4322	s_return (newstr);	4389	s_return (newstr);
4323	}	4390	}
4324		4391
4325	case OP_SUBSTR: /* substring */	4392	case OP_STRING_COPY: /* substring/string-copy */
4326	{	4393	{
4327	char *str = strvalue (x);	4394	char *str = strvalue (x);
4328	int index0 = ivalue_unchecked (cadr (args));	4395	int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4329	int index1;	4396	int index1;
4330	int len;	4397	int len;
4331		4398
4332	if (index0 > strlength (x))	4399	if (index0 > strlength (x))
4333	Error_1 ("substring: start out of bounds:", cadr (args));	4400	Error_1 ("string->copy: start out of bounds:", cadr (args));
4334		4401
4335	if (cddr (args) != NIL)	4402	if (cddr (args) != NIL)
4336	{	4403	{
4337	index1 = ivalue_unchecked (caddr (args));	4404	index1 = ivalue_unchecked (caddr (args));
4338		4405
4339	if (index1 > strlength (x) || index1 < index0)	4406	if (index1 > strlength (x) || index1 < index0)
4340	Error_1 ("substring: end out of bounds:", caddr (args));	4407	Error_1 ("string->copy: end out of bounds:", caddr (args));
4341	}	4408	}
4342	else	4409	else
4343	index1 = strlength (x);	4410	index1 = strlength (x);
4344		4411
4345	len = index1 - index0;	4412	len = index1 - index0;
4346	x = mk_empty_string (SCHEME_A_ len, ' ');	4413	x = mk_counted_string (SCHEME_A_ str + index0, len);
4347	memcpy (strvalue (x), str + index0, len);
4348	strvalue (x)[len] = 0;
4349		4414
4350	s_return (x);	4415	s_return (x);
4351	}	4416	}
4352		4417
4353	case OP_VECTOR: /* vector */	4418	case OP_VECTOR: /* vector */
…		…
4395	}	4460	}
4396		4461
4397	case OP_VECLEN: /* vector-length */	4462	case OP_VECLEN: /* vector-length */
4398	s_return (mk_integer (SCHEME_A_ veclength (x)));	4463	s_return (mk_integer (SCHEME_A_ veclength (x)));
4399		4464
		4465	case OP_VECRESIZE:
		4466	vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
		4467	s_return (x);
		4468
4400	case OP_VECREF: /* vector-ref */	4469	case OP_VECREF: /* vector-ref */
4401	{	4470	{
4402	int index = ivalue_unchecked (cadr (args));	4471	int index = ivalue_unchecked (cadr (args));
4403		4472
4404	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)	4473	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
…		…
4423	}	4492	}
4424		4493
4425	if (USE_ERROR_CHECKING) abort ();	4494	if (USE_ERROR_CHECKING) abort ();
4426	}	4495	}
4427		4496
4428	static int	4497	/* relational ops */
		4498	ecb_hot static int
4429	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	4499	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4430	{	4500	{
4431	pointer x = SCHEME_V->args;	4501	pointer x = SCHEME_V->args;
4432		4502
4433	for (;;)	4503	for (;;)
…		…
4454	}	4524	}
4455		4525
4456	s_return (S_T);	4526	s_return (S_T);
4457	}	4527	}
4458		4528
4459	static int	4529	/* predicates */
		4530	ecb_hot static int
4460	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4531	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4461	{	4532	{
4462	pointer args = SCHEME_V->args;	4533	pointer args = SCHEME_V->args;
4463	pointer a = car (args);	4534	pointer a = car (args);
4464	pointer d = cdr (args);	4535	pointer d = cdr (args);
4465	int r;	4536	int r;
4466		4537
4467	switch (op)	4538	switch (op)
4468	{	4539	{
4469	case OP_NOT: /* not */ r = is_false (a) ; break;	4540	case OP_NOT: /* not */ r = is_false (a) ; break;
4470	case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break;	4541	case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break;
4471	case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;	4542	case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4472	case OP_NULLP: /* null? */ r = a == NIL ; break;	4543	case OP_NULLP: /* null? */ r = a == NIL ; break;
4473	case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;	4544	case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
		4545	case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break;
4474	case OP_NUMBERP: /* number? */ r = is_number (a) ; break;	4546	case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4475	case OP_STRINGP: /* string? */ r = is_string (a) ; break;	4547	case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4476	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;	4548	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4477	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */	4549	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4478	case OP_CHARP: /* char? */ r = is_character (a) ; break;	4550	case OP_CHARP: /* char? */ r = is_character (a) ; break;
4479		4551
4480	#if USE_CHAR_CLASSIFIERS	4552	#if USE_CHAR_CLASSIFIERS
4481	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;	4553	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4482	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;	4554	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4483	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;	4555	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
…		…
4510	}	4582	}
4511		4583
4512	s_retbool (r);	4584	s_retbool (r);
4513	}	4585	}
4514		4586
4515	static int	4587	/* promises, list ops, ports */
		4588	ecb_hot static int
4516	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4589	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4517	{	4590	{
4518	pointer args = SCHEME_V->args;	4591	pointer args = SCHEME_V->args;
4519	pointer a = car (args);	4592	pointer a = car (args);
4520	pointer x, y;	4593	pointer x, y;
…		…
4533	}	4606	}
4534	else	4607	else
4535	s_return (SCHEME_V->code);	4608	s_return (SCHEME_V->code);
4536		4609
4537	case OP_SAVE_FORCED: /* Save forced value replacing promise */	4610	case OP_SAVE_FORCED: /* Save forced value replacing promise */
4538	memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell));	4611	*CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4539	s_return (SCHEME_V->value);	4612	s_return (SCHEME_V->value);
4540		4613
4541	#if USE_PORTS	4614	#if USE_PORTS
		4615
		4616	case OP_EOF_OBJECT: /* eof-object */
		4617	s_return (S_EOF);
4542		4618
4543	case OP_WRITE: /* write */	4619	case OP_WRITE: /* write */
4544	case OP_DISPLAY: /* display */	4620	case OP_DISPLAY: /* display */
4545	case OP_WRITE_CHAR: /* write-char */	4621	case OP_WRITE_CHAR: /* write-char */
4546	if (is_pair (cdr (SCHEME_V->args)))	4622	if (is_pair (cdr (SCHEME_V->args)))
…		…
4688	SCHEME_V->gc_verbose = (a != S_F);	4764	SCHEME_V->gc_verbose = (a != S_F);
4689	s_retbool (was);	4765	s_retbool (was);
4690	}	4766	}
4691		4767
4692	case OP_NEWSEGMENT: /* new-segment */	4768	case OP_NEWSEGMENT: /* new-segment */
		4769	#if 0
4693	if (!is_pair (args) || !is_number (a))	4770	if (!is_pair (args) || !is_number (a))
4694	Error_0 ("new-segment: argument must be a number");	4771	Error_0 ("new-segment: argument must be a number");
4695		4772	#endif
4696	alloc_cellseg (SCHEME_A_ ivalue (a));	4773	s_retbool (alloc_cellseg (SCHEME_A));
4697
4698	s_return (S_T);
4699		4774
4700	case OP_OBLIST: /* oblist */	4775	case OP_OBLIST: /* oblist */
4701	s_return (oblist_all_symbols (SCHEME_A));	4776	s_return (oblist_all_symbols (SCHEME_A));
4702		4777
4703	#if USE_PORTS	4778	#if USE_PORTS
…		…
4773	s_return (p == NIL ? S_F : p);	4848	s_return (p == NIL ? S_F : p);
4774	}	4849	}
4775		4850
4776	case OP_GET_OUTSTRING: /* get-output-string */	4851	case OP_GET_OUTSTRING: /* get-output-string */
4777	{	4852	{
4778	port *p;	4853	port *p = port (a);
4779		4854
4780	if ((p = a->object.port)->kind & port_string)	4855	if (p->kind & port_string)
4781	{	4856	{
4782	off_t size;	4857	off_t size;
4783	char *str;	4858	char *str;
4784		4859
4785	size = p->rep.string.curr - p->rep.string.start + 1;	4860	size = p->rep.string.curr - p->rep.string.start + 1;
…		…
4820	}	4895	}
4821		4896
4822	if (USE_ERROR_CHECKING) abort ();	4897	if (USE_ERROR_CHECKING) abort ();
4823	}	4898	}
4824		4899
4825	static int	4900	/* reading */
		4901	ecb_cold static int
4826	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4902	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4827	{	4903	{
4828	pointer args = SCHEME_V->args;	4904	pointer args = SCHEME_V->args;
4829	pointer x;	4905	pointer x;
4830		4906
…		…
4890	int res;	4966	int res;
4891		4967
4892	if (is_pair (args))	4968	if (is_pair (args))
4893	p = car (args);	4969	p = car (args);
4894		4970
4895	res = p->object.port->kind & port_string;	4971	res = port (p)->kind & port_string;
4896		4972
4897	s_retbool (res);	4973	s_retbool (res);
4898	}	4974	}
4899		4975
4900	case OP_SET_INPORT: /* set-input-port */	4976	case OP_SET_INPORT: /* set-input-port */
…		…
4959	s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);	5035	s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
4960	SCHEME_V->tok = token (SCHEME_A);	5036	SCHEME_V->tok = token (SCHEME_A);
4961	s_goto (OP_RDSEXPR);	5037	s_goto (OP_RDSEXPR);
4962		5038
4963	case TOK_ATOM:	5039	case TOK_ATOM:
4964	s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS)));	5040	s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));
		5041
		5042	case TOK_DOTATOM:
		5043	SCHEME_V->strbuff[0] = '.';
		5044	s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
		5045
		5046	case TOK_STRATOM:
		5047	x = readstrexp (SCHEME_A_ '|');
		5048	//TODO: haven't checked whether the garbage collector could interfere
		5049	s_return (mk_atom (SCHEME_A_ strvalue (x)));
4965		5050
4966	case TOK_DQUOTE:	5051	case TOK_DQUOTE:
4967	x = readstrexp (SCHEME_A);	5052	x = readstrexp (SCHEME_A_ '"');
4968		5053
4969	if (x == S_F)	5054	if (x == S_F)
4970	Error_0 ("Error reading string");	5055	Error_0 ("Error reading string");
4971		5056
4972	setimmutable (x);	5057	setimmutable (x);
…		…
4984	s_goto (OP_EVAL);	5069	s_goto (OP_EVAL);
4985	}	5070	}
4986	}	5071	}
4987		5072
4988	case TOK_SHARP_CONST:	5073	case TOK_SHARP_CONST:
4989	if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL)	5074	if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
4990	Error_0 ("undefined sharp expression");	5075	Error_0 ("undefined sharp expression");
4991	else	5076	else
4992	s_return (x);	5077	s_return (x);
4993		5078
4994	default:	5079	default:
…		…
5163	}	5248	}
5164		5249
5165	if (USE_ERROR_CHECKING) abort ();	5250	if (USE_ERROR_CHECKING) abort ();
5166	}	5251	}
5167		5252
5168	static int	5253	/* list ops */
		5254	ecb_hot static int
5169	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5255	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5170	{	5256	{
5171	pointer args = SCHEME_V->args;	5257	pointer args = SCHEME_V->args;
5172	pointer a = car (args);	5258	pointer a = car (args);
5173	pointer x, y;	5259	pointer x, y;
…		…
5216		5302
5217	case OP_CLOSUREP: /* closure? */	5303	case OP_CLOSUREP: /* closure? */
5218	/*	5304	/*
5219	* Note, macro object is also a closure.	5305	* Note, macro object is also a closure.
5220	* Therefore, (closure? <#MACRO>) ==> #t	5306	* Therefore, (closure? <#MACRO>) ==> #t
		5307	* (schmorp) well, obviously not, fix? TODO
5221	*/	5308	*/
5222	s_retbool (is_closure (a));	5309	s_retbool (is_closure (a));
5223		5310
5224	case OP_MACROP: /* macro? */	5311	case OP_MACROP: /* macro? */
5225	s_retbool (is_macro (a));	5312	s_retbool (is_macro (a));
…		…
5230		5317
5231	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */	5318	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5232	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);	5319	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5233		5320
5234	typedef int (*test_predicate)(pointer);	5321	typedef int (*test_predicate)(pointer);
5235	static int	5322
		5323	ecb_hot static int
5236	tst_any (pointer p)	5324	tst_any (pointer p)
5237	{	5325	{
5238	return 1;	5326	return 1;
5239	}	5327	}
5240		5328
5241	static int	5329	ecb_hot static int
5242	tst_inonneg (pointer p)	5330	tst_inonneg (pointer p)
5243	{	5331	{
5244	return is_integer (p) && ivalue_unchecked (p) >= 0;	5332	return is_integer (p) && ivalue_unchecked (p) >= 0;
5245	}	5333	}
5246		5334
5247	static int	5335	ecb_hot static int
5248	tst_is_list (SCHEME_P_ pointer p)	5336	tst_is_list (SCHEME_P_ pointer p)
5249	{	5337	{
5250	return p == NIL || is_pair (p);	5338	return p == NIL || is_pair (p);
5251	}	5339	}
5252		5340
…		…
5295	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"	5383	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5296	#include "opdefines.h"	5384	#include "opdefines.h"
5297	#undef OP_DEF	5385	#undef OP_DEF
5298	;	5386	;
5299		5387
5300	static const char *	5388	ecb_cold static const char *
5301	opname (int idx)	5389	opname (int idx)
5302	{	5390	{
5303	const char *name = opnames;	5391	const char *name = opnames;
5304		5392
5305	/* should do this at compile time, but would require external program, right? */	5393	/* should do this at compile time, but would require external program, right? */
…		…
5307	name += strlen (name) + 1;	5395	name += strlen (name) + 1;
5308		5396
5309	return *name ? name : "ILLEGAL";	5397	return *name ? name : "ILLEGAL";
5310	}	5398	}
5311		5399
5312	static const char *	5400	ecb_cold static const char *
5313	procname (pointer x)	5401	procname (pointer x)
5314	{	5402	{
5315	return opname (procnum (x));	5403	return opname (procnum (x));
5316	}	5404	}
5317		5405
…		…
5337	#undef OP_DEF	5425	#undef OP_DEF
5338	{0}	5426	{0}
5339	};	5427	};
5340		5428
5341	/* kernel of this interpreter */	5429	/* kernel of this interpreter */
5342	static void ecb_hot	5430	ecb_hot static void
5343	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5431	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5344	{	5432	{
5345	SCHEME_V->op = op;	5433	SCHEME_V->op = op;
5346		5434
5347	for (;;)	5435	for (;;)
…		…
5430	if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))	5518	if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5431	return;	5519	return;
5432		5520
5433	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	5521	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5434	{	5522	{
5435	xwrstr ("No memory!\n");	5523	putstr (SCHEME_A_ "No memory!\n");
5436	return;	5524	return;
5437	}	5525	}
5438	}	5526	}
5439	}	5527	}
5440		5528
5441	/* ========== Initialization of internal keywords ========== */	5529	/* ========== Initialization of internal keywords ========== */
5442		5530
5443	static void	5531	ecb_cold static void
5444	assign_syntax (SCHEME_P_ const char *name)	5532	assign_syntax (SCHEME_P_ const char *name)
5445	{	5533	{
5446	pointer x = oblist_add_by_name (SCHEME_A_ name);	5534	pointer x = oblist_add_by_name (SCHEME_A_ name);
5447	set_typeflag (x, typeflag (x) | T_SYNTAX);	5535	set_typeflag (x, typeflag (x) | T_SYNTAX);
5448	}	5536	}
5449		5537
5450	static void	5538	ecb_cold static void
5451	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)	5539	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5452	{	5540	{
5453	pointer x = mk_symbol (SCHEME_A_ name);	5541	pointer x = mk_symbol (SCHEME_A_ name);
5454	pointer y = mk_proc (SCHEME_A_ op);	5542	pointer y = mk_proc (SCHEME_A_ op);
5455	new_slot_in_env (SCHEME_A_ x, y);	5543	new_slot_in_env (SCHEME_A_ x, y);
…		…
5463	ivalue_unchecked (y) = op;	5551	ivalue_unchecked (y) = op;
5464	return y;	5552	return y;
5465	}	5553	}
5466		5554
5467	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */	5555	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5468	static int	5556	ecb_hot static int
5469	syntaxnum (pointer p)	5557	syntaxnum (pointer p)
5470	{	5558	{
5471	const char *s = strvalue (car (p));	5559	const char *s = strvalue (p);
5472		5560
5473	switch (strlength (car (p)))	5561	switch (strlength (p))
5474	{	5562	{
5475	case 2:	5563	case 2:
5476	if (s[0] == 'i')	5564	if (s[0] == 'i')
5477	return OP_IF0; /* if */	5565	return OP_IF0; /* if */
5478	else	5566	else
…		…
5553	ecb_cold int	5641	ecb_cold int
5554	scheme_init (SCHEME_P)	5642	scheme_init (SCHEME_P)
5555	{	5643	{
5556	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	5644	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5557	pointer x;	5645	pointer x;
		5646
		5647	/* this memset is not strictly correct, as we assume (intcache)
		5648	* that memset 0 will also set pointers to 0, but memset does
		5649	* of course not guarantee that. screw such systems.
		5650	*/
		5651	memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5558		5652
5559	num_set_fixnum (num_zero, 1);	5653	num_set_fixnum (num_zero, 1);
5560	num_set_ivalue (num_zero, 0);	5654	num_set_ivalue (num_zero, 0);
5561	num_set_fixnum (num_one, 1);	5655	num_set_fixnum (num_one, 1);
5562	num_set_ivalue (num_one, 1);	5656	num_set_ivalue (num_one, 1);
…		…
5574	SCHEME_V->save_inport = NIL;	5668	SCHEME_V->save_inport = NIL;
5575	SCHEME_V->loadport = NIL;	5669	SCHEME_V->loadport = NIL;
5576	SCHEME_V->nesting = 0;	5670	SCHEME_V->nesting = 0;
5577	SCHEME_V->interactive_repl = 0;	5671	SCHEME_V->interactive_repl = 0;
5578		5672
5579	if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS)	5673	if (!alloc_cellseg (SCHEME_A))
5580	{	5674	{
5581	#if USE_ERROR_CHECKING	5675	#if USE_ERROR_CHECKING
5582	SCHEME_V->no_memory = 1;	5676	SCHEME_V->no_memory = 1;
5583	return 0;	5677	return 0;
5584	#endif	5678	#endif
…		…
5652		5746
5653	return !SCHEME_V->no_memory;	5747	return !SCHEME_V->no_memory;
5654	}	5748	}
5655		5749
5656	#if USE_PORTS	5750	#if USE_PORTS
5657	void	5751	ecb_cold void
5658	scheme_set_input_port_file (SCHEME_P_ int fin)	5752	scheme_set_input_port_file (SCHEME_P_ int fin)
5659	{	5753	{
5660	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);	5754	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5661	}	5755	}
5662		5756
5663	void	5757	ecb_cold void
5664	scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)	5758	scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5665	{	5759	{
5666	SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);	5760	SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5667	}	5761	}
5668		5762
5669	void	5763	ecb_cold void
5670	scheme_set_output_port_file (SCHEME_P_ int fout)	5764	scheme_set_output_port_file (SCHEME_P_ int fout)
5671	{	5765	{
5672	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);	5766	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5673	}	5767	}
5674		5768
5675	void	5769	ecb_cold void
5676	scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)	5770	scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5677	{	5771	{
5678	SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);	5772	SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5679	}	5773	}
5680	#endif	5774	#endif
5681		5775
5682	void	5776	ecb_cold void
5683	scheme_set_external_data (SCHEME_P_ void *p)	5777	scheme_set_external_data (SCHEME_P_ void *p)
5684	{	5778	{
5685	SCHEME_V->ext_data = p;	5779	SCHEME_V->ext_data = p;
5686	}	5780	}
5687		5781
…		…
5735	}	5829	}
5736	}	5830	}
5737	#endif	5831	#endif
5738	}	5832	}
5739		5833
5740	void	5834	ecb_cold void
5741	scheme_load_file (SCHEME_P_ int fin)	5835	scheme_load_file (SCHEME_P_ int fin)
5742	{	5836	{
5743	scheme_load_named_file (SCHEME_A_ fin, 0);	5837	scheme_load_named_file (SCHEME_A_ fin, 0);
5744	}	5838	}
5745		5839
5746	void	5840	ecb_cold void
5747	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)	5841	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5748	{	5842	{
5749	dump_stack_reset (SCHEME_A);	5843	dump_stack_reset (SCHEME_A);
5750	SCHEME_V->envir = SCHEME_V->global_env;	5844	SCHEME_V->envir = SCHEME_V->global_env;
5751	SCHEME_V->file_i = 0;	5845	SCHEME_V->file_i = 0;
…		…
5778		5872
5779	if (SCHEME_V->retcode == 0)	5873	if (SCHEME_V->retcode == 0)
5780	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5874	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5781	}	5875	}
5782		5876
5783	void	5877	ecb_cold void
5784	scheme_load_string (SCHEME_P_ const char *cmd)	5878	scheme_load_string (SCHEME_P_ const char *cmd)
5785	{	5879	{
5786	dump_stack_reset (SCHEME_A);	5880	dump_stack_reset (SCHEME_A);
5787	SCHEME_V->envir = SCHEME_V->global_env;	5881	SCHEME_V->envir = SCHEME_V->global_env;
5788	SCHEME_V->file_i = 0;	5882	SCHEME_V->file_i = 0;
…		…
5802		5896
5803	if (SCHEME_V->retcode == 0)	5897	if (SCHEME_V->retcode == 0)
5804	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5898	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5805	}	5899	}
5806		5900
5807	void	5901	ecb_cold void
5808	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)	5902	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5809	{	5903	{
5810	pointer x;	5904	pointer x;
5811		5905
5812	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);	5906	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
…		…
5817	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);	5911	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5818	}	5912	}
5819		5913
5820	#if !STANDALONE	5914	#if !STANDALONE
5821		5915
5822	void	5916	ecb_cold void
5823	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)	5917	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5824	{	5918	{
5825	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));	5919	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5826	}	5920	}
5827		5921
5828	void	5922	ecb_cold void
5829	scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)	5923	scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5830	{	5924	{
5831	int i;	5925	int i;
5832		5926
5833	for (i = 0; i < count; i++)	5927	for (i = 0; i < count; i++)
5834	scheme_register_foreign_func (SCHEME_A_ list + i);	5928	scheme_register_foreign_func (SCHEME_A_ list + i);
5835	}	5929	}
5836		5930
5837	pointer	5931	ecb_cold pointer
5838	scheme_apply0 (SCHEME_P_ const char *procname)	5932	scheme_apply0 (SCHEME_P_ const char *procname)
5839	{	5933	{
5840	return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));	5934	return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5841	}	5935	}
5842		5936
5843	void	5937	ecb_cold void
5844	save_from_C_call (SCHEME_P)	5938	save_from_C_call (SCHEME_P)
5845	{	5939	{
5846	pointer saved_data = cons (car (S_SINK),	5940	pointer saved_data = cons (car (S_SINK),
5847	cons (SCHEME_V->envir,	5941	cons (SCHEME_V->envir,
5848	SCHEME_V->dump));	5942	SCHEME_V->dump));
…		…
5852	/* Truncate the dump stack so TS will return here when done, not	5946	/* Truncate the dump stack so TS will return here when done, not
5853	directly resume pre-C-call operations. */	5947	directly resume pre-C-call operations. */
5854	dump_stack_reset (SCHEME_A);	5948	dump_stack_reset (SCHEME_A);
5855	}	5949	}
5856		5950
5857	void	5951	ecb_cold void
5858	restore_from_C_call (SCHEME_P)	5952	restore_from_C_call (SCHEME_P)
5859	{	5953	{
5860	set_car (S_SINK, caar (SCHEME_V->c_nest));	5954	set_car (S_SINK, caar (SCHEME_V->c_nest));
5861	SCHEME_V->envir = cadar (SCHEME_V->c_nest);	5955	SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5862	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));	5956	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5863	/* Pop */	5957	/* Pop */
5864	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);	5958	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5865	}	5959	}
5866		5960
5867	/* "func" and "args" are assumed to be already eval'ed. */	5961	/* "func" and "args" are assumed to be already eval'ed. */
5868	pointer	5962	ecb_cold pointer
5869	scheme_call (SCHEME_P_ pointer func, pointer args)	5963	scheme_call (SCHEME_P_ pointer func, pointer args)
5870	{	5964	{
5871	int old_repl = SCHEME_V->interactive_repl;	5965	int old_repl = SCHEME_V->interactive_repl;
5872		5966
5873	SCHEME_V->interactive_repl = 0;	5967	SCHEME_V->interactive_repl = 0;
…		…
5880	SCHEME_V->interactive_repl = old_repl;	5974	SCHEME_V->interactive_repl = old_repl;
5881	restore_from_C_call (SCHEME_A);	5975	restore_from_C_call (SCHEME_A);
5882	return SCHEME_V->value;	5976	return SCHEME_V->value;
5883	}	5977	}
5884		5978
5885	pointer	5979	ecb_cold pointer
5886	scheme_eval (SCHEME_P_ pointer obj)	5980	scheme_eval (SCHEME_P_ pointer obj)
5887	{	5981	{
5888	int old_repl = SCHEME_V->interactive_repl;	5982	int old_repl = SCHEME_V->interactive_repl;
5889		5983
5890	SCHEME_V->interactive_repl = 0;	5984	SCHEME_V->interactive_repl = 0;
…		…
5902		5996
5903	/* ========== Main ========== */	5997	/* ========== Main ========== */
5904		5998
5905	#if STANDALONE	5999	#if STANDALONE
5906		6000
5907	int	6001	ecb_cold int
5908	main (int argc, char **argv)	6002	main (int argc, char **argv)
5909	{	6003	{
5910	# if USE_MULTIPLICITY	6004	# if USE_MULTIPLICITY
5911	scheme ssc;	6005	scheme ssc;
5912	scheme *const SCHEME_V = &ssc;	6006	scheme *const SCHEME_V = &ssc;
…		…
5914	# endif	6008	# endif
5915	int fin;	6009	int fin;
5916	char *file_name = InitFile;	6010	char *file_name = InitFile;
5917	int retcode;	6011	int retcode;
5918	int isfile = 1;	6012	int isfile = 1;
		6013	system ("ps v $PPID");//D
5919		6014
5920	if (argc == 2 && strcmp (argv[1], "-?") == 0)	6015	if (argc == 2 && strcmp (argv[1], "-?") == 0)
5921	{	6016	{
5922	xwrstr ("Usage: tinyscheme -?\n");	6017	putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
5923	xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");	6018	putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
5924	xwrstr ("followed by\n");	6019	putstr (SCHEME_A_ "followed by\n");
5925	xwrstr (" -1 <file> [<arg1> <arg2> ...]\n");	6020	putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
5926	xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n");	6021	putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
5927	xwrstr ("assuming that the executable is named tinyscheme.\n");	6022	putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
5928	xwrstr ("Use - as filename for stdin.\n");	6023	putstr (SCHEME_A_ "Use - as filename for stdin.\n");
5929	return 1;	6024	return 1;
5930	}	6025	}
5931		6026
5932	if (!scheme_init (SCHEME_A))	6027	if (!scheme_init (SCHEME_A))
5933	{	6028	{
5934	xwrstr ("Could not initialize!\n");	6029	putstr (SCHEME_A_ "Could not initialize!\n");
5935	return 2;	6030	return 2;
5936	}	6031	}
5937		6032
5938	# if USE_PORTS	6033	# if USE_PORTS
5939	scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);	6034	scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
…		…
5984	fin = open (file_name, O_RDONLY);	6079	fin = open (file_name, O_RDONLY);
5985	#endif	6080	#endif
5986		6081
5987	if (isfile && fin < 0)	6082	if (isfile && fin < 0)
5988	{	6083	{
5989	xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n");	6084	putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
5990	}	6085	}
5991	else	6086	else
5992	{	6087	{
5993	if (isfile)	6088	if (isfile)
5994	scheme_load_named_file (SCHEME_A_ fin, file_name);	6089	scheme_load_named_file (SCHEME_A_ fin, file_name);
…		…
5998	#if USE_PORTS	6093	#if USE_PORTS
5999	if (!isfile || fin != STDIN_FILENO)	6094	if (!isfile || fin != STDIN_FILENO)
6000	{	6095	{
6001	if (SCHEME_V->retcode != 0)	6096	if (SCHEME_V->retcode != 0)
6002	{	6097	{
6003	xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n");	6098	putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6004	}	6099	}
6005		6100
6006	if (isfile)	6101	if (isfile)
6007	close (fin);	6102	close (fin);
6008	}	6103	}

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines