ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/cvsroot/microscheme/scheme.c

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.8 by root, Wed Nov 25 22:36:25 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>
28	#endif	32	#endif
29	#if USE_MATH	33	#if USE_MATH
30	# include <math.h>	34	# include <math.h>
31	#endif	35	#endif
32		36
		37	#include "ecb.h"
		38
33	#include <sys/types.h>	39	#include <sys/types.h>
34	#include <sys/stat.h>	40	#include <sys/stat.h>
35	#include <fcntl.h>	41	#include <fcntl.h>
36		42
		43	#if !USE_ERROR_CHECKING
		44	# define NDEBUG
		45	#endif
		46
		47	#include <assert.h>
		48	#include <stdlib.h>
37	#include <string.h>	49	#include <string.h>
38	#include <stdlib.h>
39		50
40	#include <limits.h>	51	#include <limits.h>
41	#include <inttypes.h>	52	#include <inttypes.h>
42	#include <float.h>	53	#include <float.h>
43	//#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
44		63
45	enum {	64	enum {
46	TOK_EOF,	65	TOK_EOF,
47	TOK_LPAREN,	66	TOK_LPAREN,
48	TOK_RPAREN,	67	TOK_RPAREN,
49	TOK_DOT,	68	TOK_DOT,
50	TOK_ATOM,	69	TOK_ATOM,
		70	TOK_DOTATOM, /* atom name starting with '.' */
		71	TOK_STRATOM, /* atom name enclosed in | */
51	TOK_QUOTE,	72	TOK_QUOTE,
52	TOK_DQUOTE,	73	TOK_DQUOTE,
53	TOK_BQUOTE,	74	TOK_BQUOTE,
54	TOK_COMMA,	75	TOK_COMMA,
55	TOK_ATMARK,	76	TOK_ATMARK,
…		…
57	TOK_SHARP_CONST,	78	TOK_SHARP_CONST,
58	TOK_VEC	79	TOK_VEC
59	};	80	};
60		81
61	#define BACKQUOTE '`'	82	#define BACKQUOTE '`'
62	#define DELIMITERS "()\";\f\t\v\n\r "	83	#define WHITESPACE " \t\r\n\v\f"
		84	#define DELIMITERS "()\";" WHITESPACE
63		85
64	#define NIL (&SCHEME_V->xNIL) //TODO: make this 0?	86	#define NIL POINTER (&SCHEME_V->xNIL)
65	#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?	87	#define S_T POINTER (&SCHEME_V->xT)
66	#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?	88	#define S_F POINTER (&SCHEME_V->xF)
67	#define S_SINK (&SCHEME_V->xsink)	89	#define S_SINK POINTER (&SCHEME_V->xsink)
68	#define S_EOF (&SCHEME_V->xEOF_OBJ)	90	#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
69		91
70	#if !USE_MULTIPLICITY	92	#if !USE_MULTIPLICITY
71	static scheme sc;	93	static scheme sc;
72	#endif	94	#endif
73		95
74	static void	96	ecb_cold static void
75	xbase (char *s, long n, int base)	97	xbase (char *s, long n, int base)
76	{	98	{
77	if (n < 0)	99	if (n < 0)
78	{	100	{
79	*s++ = '-';	101	*s++ = '-';
…		…
81	}	103	}
82		104
83	char *p = s;	105	char *p = s;
84		106
85	do {	107	do {
86	*p++ = '0' + n % base;	108	*p++ = "0123456789abcdef"[n % base];
87	n /= base;	109	n /= base;
88	} while (n);	110	} while (n);
89		111
90	*p-- = 0;	112	*p-- = 0;
91		113
…		…
94	char x = *s; *s = *p; *p = x;	116	char x = *s; *s = *p; *p = x;
95	--p; ++s;	117	--p; ++s;
96	}	118	}
97	}	119	}
98		120
99	static void	121	ecb_cold static void
100	xnum (char *s, long n)	122	xnum (char *s, long n)
101	{	123	{
102	xbase (s, n, 10);	124	xbase (s, n, 10);
103	}	125	}
104		126
105	static void	127	ecb_cold static void
106	xwrstr (const char *s)	128	putnum (SCHEME_P_ long n)
107	{
108	write (1, s, strlen (s));
109	}
110
111	static void
112	xwrnum (long n)
113	{	129	{
114	char buf[64];	130	char buf[64];
115		131
116	xnum (buf, n);	132	xnum (buf, n);
117	xwrstr (buf);	133	putstr (SCHEME_A_ buf);
118	}	134	}
119		135
120	static char	136	ecb_cold static char
121	xtoupper (char c)	137	xtoupper (char c)
122	{	138	{
123	if (c >= 'a' && c <= 'z')	139	if (c >= 'a' && c <= 'z')
124	c -= 'a' - 'A';	140	c -= 'a' - 'A';
125		141
126	return c;	142	return c;
127	}	143	}
128		144
129	static char	145	ecb_cold static char
130	xtolower (char c)	146	xtolower (char c)
131	{	147	{
132	if (c >= 'A' && c <= 'Z')	148	if (c >= 'A' && c <= 'Z')
133	c += 'a' - 'A';	149	c += 'a' - 'A';
134		150
135	return c;	151	return c;
136	}	152	}
137		153
138	static int	154	ecb_cold static int
139	xisdigit (char c)	155	xisdigit (char c)
140	{	156	{
141	return c >= '0' && c <= '9';	157	return c >= '0' && c <= '9';
142	}	158	}
143		159
144	#define toupper(c) xtoupper (c)	160	#define toupper(c) xtoupper (c)
145	#define tolower(c) xtolower (c)	161	#define tolower(c) xtolower (c)
146	#define isdigit(c) xisdigit (c)	162	#define isdigit(c) xisdigit (c)
147		163
148	#if USE_STRLWR	164	#if USE_IGNORECASE
149	static const char *	165	ecb_cold static const char *
150	strlwr (char *s)	166	xstrlwr (char *s)
151	{	167	{
152	const char *p = s;	168	const char *p = s;
153		169
154	while (*s)	170	while (*s)
155	{	171	{
…		…
157	s++;	173	s++;
158	}	174	}
159		175
160	return p;	176	return p;
161	}	177	}
162	#endif
163		178
		179	#define stricmp(a,b) strcasecmp (a, b)
		180	#define strlwr(s) xstrlwr (s)
		181
		182	#else
164	#define stricmp(a,b) strcmp (a, b)	183	# define stricmp(a,b) strcmp (a, b)
165	#define strlwr(s) (s)	184	# define strlwr(s) (s)
		185	#endif
166		186
167	#ifndef prompt	187	#ifndef prompt
168	# define prompt "ts> "	188	# define prompt "ts> "
169	#endif	189	#endif
170		190
171	#ifndef InitFile	191	#ifndef InitFile
172	# define InitFile "init.scm"	192	# define InitFile "init.scm"
173	#endif	193	#endif
174		194
175	#ifndef FIRST_CELLSEGS
176	# define FIRST_CELLSEGS 3
177	#endif
178
179	enum scheme_types	195	enum scheme_types
180	{	196	{
		197	T_INTEGER,
		198	T_CHARACTER,
181	T_FREE,	199	T_REAL,
182	T_STRING,	200	T_STRING,
183	T_NUMBER,
184	T_SYMBOL,	201	T_SYMBOL,
185	T_PROC,	202	T_PROC,
186	T_PAIR,	203	T_PAIR, /* also used for free cells */
187	T_CLOSURE,	204	T_CLOSURE,
		205	T_MACRO,
188	T_CONTINUATION,	206	T_CONTINUATION,
189	T_FOREIGN,	207	T_FOREIGN,
190	T_CHARACTER,
191	T_PORT,	208	T_PORT,
192	T_VECTOR,	209	T_VECTOR,
193	T_MACRO,
194	T_PROMISE,	210	T_PROMISE,
195	T_ENVIRONMENT,	211	T_ENVIRONMENT,
196	/* one more... */	212	/* one more... */
197	T_NUM_SYSTEM_TYPES	213	T_NUM_SYSTEM_TYPES
198	};	214	};
…		…
201	#define T_SYNTAX 0x0010	217	#define T_SYNTAX 0x0010
202	#define T_IMMUTABLE 0x0020	218	#define T_IMMUTABLE 0x0020
203	#define T_ATOM 0x0040 /* only for gc */	219	#define T_ATOM 0x0040 /* only for gc */
204	#define T_MARK 0x0080 /* only for gc */	220	#define T_MARK 0x0080 /* only for gc */
205		221
206	static num num_add (num a, num b);	222	/* num, for generic arithmetic */
207	static num num_mul (num a, num b);	223	struct num
208	static num num_div (num a, num b);	224	{
		225	IVALUE ivalue;
		226	#if USE_REAL
		227	RVALUE rvalue;
		228	char is_fixnum;
		229	#endif
		230	};
		231
		232	#if USE_REAL
		233	# define num_is_fixnum(n) (n).is_fixnum
		234	# define num_set_fixnum(n,f) (n).is_fixnum = (f)
		235	# define num_ivalue(n) (n).ivalue
		236	# define num_rvalue(n) (n).rvalue
		237	# define num_set_ivalue(n,i) (n).rvalue = (n).ivalue = (i)
		238	# define num_set_rvalue(n,r) (n).rvalue = (r)
		239	#else
		240	# define num_is_fixnum(n) 1
		241	# define num_set_fixnum(n,f) 0
		242	# define num_ivalue(n) (n).ivalue
		243	# define num_rvalue(n) (n).ivalue
		244	# define num_set_ivalue(n,i) (n).ivalue = (i)
		245	# define num_set_rvalue(n,r) (n).ivalue = (r)
		246	#endif
		247
		248	enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };
		249
		250	static num num_op (enum num_op op, num a, num b);
209	static num num_intdiv (num a, num b);	251	static num num_intdiv (num a, num b);
210	static num num_sub (num a, num b);
211	static num num_rem (num a, num b);	252	static num num_rem (num a, num b);
212	static num num_mod (num a, num b);	253	static num num_mod (num a, num b);
213	static int num_eq (num a, num b);
214	static int num_gt (num a, num b);
215	static int num_ge (num a, num b);
216	static int num_lt (num a, num b);
217	static int num_le (num a, num b);
218		254
219	#if USE_MATH
220	static double round_per_R5RS (double x);
221	#endif
222	static int is_zero_rvalue (RVALUE x);	255	static int is_zero_rvalue (RVALUE x);
223
224	static INLINE int
225	num_is_integer (pointer p)
226	{
227	return num_is_fixnum (p->object.number);
228	}
229		256
230	static num num_zero;	257	static num num_zero;
231	static num num_one;	258	static num num_one;
232		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
233	/* macros for cell operations */	264	/* macros for cell operations */
234	#define typeflag(p) ((p)->flag + 0)	265	#define typeflag(p) (CELL(p)->flag + 0)
235	#define set_typeflag(p,v) ((p)->flag = (v))	266	#define set_typeflag(p,v) (CELL(p)->flag = (v))
236	#define type(p) (typeflag (p) & T_MASKTYPE)	267	#define type(p) (typeflag (p) & T_MASKTYPE)
237		268
238	INTERFACE INLINE int	269	INTERFACE int
239	is_string (pointer p)	270	is_string (pointer p)
240	{	271	{
241	return type (p) == T_STRING;	272	return type (p) == T_STRING;
242	}	273	}
243		274
244	#define strvalue(p) ((p)->object.string.svalue)	275	#define strvalue(p) (CELL(p)->object.string.svalue)
245	#define strlength(p) ((p)->object.string.length)	276	#define strlength(p) (CELL(p)->object.string.length)
246		277
247	INTERFACE int is_list (SCHEME_P_ pointer p);
248	INTERFACE INLINE int	278	INTERFACE int
249	is_vector (pointer p)	279	is_vector (pointer p)
250	{	280	{
251	return type (p) == T_VECTOR;	281	return type (p) == T_VECTOR;
252	}	282	}
253		283
254	#define vecvalue(p) ((p)->object.vector.vvalue)	284	#define vecvalue(p) (CELL(p)->object.vector.vvalue)
255	#define veclength(p) ((p)->object.vector.length)	285	#define veclength(p) (CELL(p)->object.vector.length)
256	INTERFACE void fill_vector (pointer vec, pointer obj);	286	INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
257	INTERFACE uint32_t vector_length (pointer vec);
258	INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);	287	INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
259	INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);	288	INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
260		289
261	INTERFACE uint32_t	290	INTERFACE int
262	vector_length (pointer vec)	291	is_integer (pointer p)
263	{	292	{
264	return vec->object.vector.length;	293	return type (p) == T_INTEGER;
265	}	294	}
266		295
		296	/* not the same as in scheme, where integers are (correctly :) reals */
267	INTERFACE INLINE int	297	INTERFACE int
		298	is_real (pointer p)
		299	{
		300	return type (p) == T_REAL;
		301	}
		302
		303	INTERFACE int
268	is_number (pointer p)	304	is_number (pointer p)
269	{	305	{
270	return type (p) == T_NUMBER;	306	return is_integer (p) || is_real (p);
271	}	307	}
272		308
273	INTERFACE INLINE int	309	INTERFACE int
274	is_integer (pointer p)
275	{
276	if (!is_number (p))
277	return 0;
278
279	if (num_is_integer (p) || ivalue (p) == rvalue (p))
280	return 1;
281
282	return 0;
283	}
284
285	INTERFACE INLINE int
286	is_real (pointer p)
287	{
288	return is_number (p) && !num_is_fixnum (p->object.number);
289	}
290
291	INTERFACE INLINE int
292	is_character (pointer p)	310	is_character (pointer p)
293	{	311	{
294	return type (p) == T_CHARACTER;	312	return type (p) == T_CHARACTER;
295	}	313	}
296		314
297	INTERFACE INLINE char *	315	INTERFACE char *
298	string_value (pointer p)	316	string_value (pointer p)
299	{	317	{
300	return strvalue (p);	318	return strvalue (p);
301	}	319	}
302		320
303	INLINE num
304	nvalue (pointer p)
305	{
306	return (p)->object.number;
307	}
308
309	static IVALUE
310	num_get_ivalue (const num n)
311	{
312	return num_is_fixnum (n) ? num_ivalue (n) : (IVALUE)num_rvalue (n);
313	}
314
315	static RVALUE
316	num_get_rvalue (const num n)
317	{
318	return num_is_fixnum (n) ? (RVALUE)num_ivalue (n) : num_rvalue (n);
319	}
320
321	INTERFACE IVALUE
322	ivalue (pointer p)
323	{
324	return num_get_ivalue (p->object.number);
325	}
326
327	INTERFACE RVALUE
328	rvalue (pointer p)
329	{
330	return num_get_rvalue (p->object.number);
331	}
332
333	#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)	321	#define ivalue_unchecked(p) CELL(p)->object.ivalue
		322	#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
		323
334	#if USE_REAL	324	#if USE_REAL
335	# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)	325	#define rvalue_unchecked(p) CELL(p)->object.rvalue
336	# define set_num_integer(p) (p)->object.number.is_fixnum=1;	326	#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
337	# define set_num_real(p) (p)->object.number.is_fixnum=0;
338	#else	327	#else
339	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)	328	#define rvalue_unchecked(p) CELL(p)->object.ivalue
340	# define set_num_integer(p) 0	329	#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
341	# define set_num_real(p) 0
342	#endif	330	#endif
		331
343	INTERFACE long	332	INTERFACE long
344	charvalue (pointer p)	333	charvalue (pointer p)
345	{	334	{
346	return ivalue_unchecked (p);	335	return ivalue_unchecked (p);
347	}	336	}
348		337
		338	#define port(p) CELL(p)->object.port
		339	#define set_port(p,v) port(p) = (v)
349	INTERFACE INLINE int	340	INTERFACE int
350	is_port (pointer p)	341	is_port (pointer p)
351	{	342	{
352	return type (p) == T_PORT;	343	return type (p) == T_PORT;
353	}	344	}
354		345
355	INTERFACE INLINE int	346	INTERFACE int
356	is_inport (pointer p)	347	is_inport (pointer p)
357	{	348	{
358	return is_port (p) && p->object.port->kind & port_input;	349	return is_port (p) && port (p)->kind & port_input;
359	}	350	}
360		351
361	INTERFACE INLINE int	352	INTERFACE int
362	is_outport (pointer p)	353	is_outport (pointer p)
363	{	354	{
364	return is_port (p) && p->object.port->kind & port_output;	355	return is_port (p) && port (p)->kind & port_output;
365	}	356	}
366		357
367	INTERFACE INLINE int	358	INTERFACE int
368	is_pair (pointer p)	359	is_pair (pointer p)
369	{	360	{
370	return type (p) == T_PAIR;	361	return type (p) == T_PAIR;
371	}	362	}
372		363
373	#define car(p) ((p)->object.cons.car + 0)	364	#define car(p) (POINTER (CELL(p)->object.cons.car))
374	#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */	365	#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
375		366
376	#define caar(p) car (car (p))	367	static pointer caar (pointer p) { return car (car (p)); }
377	#define cadr(p) car (cdr (p))	368	static pointer cadr (pointer p) { return car (cdr (p)); }
378	#define cdar(p) cdr (car (p))	369	static pointer cdar (pointer p) { return cdr (car (p)); }
379	#define cddr(p) cdr (cdr (p))	370	static pointer cddr (pointer p) { return cdr (cdr (p)); }
380		371
381	#define cadar(p) car (cdr (car (p)))	372	static pointer cadar (pointer p) { return car (cdr (car (p))); }
382	#define caddr(p) car (cdr (cdr (p)))	373	static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
383	#define cdaar(p) cdr (car (car (p)))	374	static pointer cdaar (pointer p) { return cdr (car (car (p))); }
384		375
385	INTERFACE void	376	INTERFACE void
386	set_car (pointer p, pointer q)	377	set_car (pointer p, pointer q)
387	{	378	{
388	p->object.cons.car = q;	379	CELL(p)->object.cons.car = CELL (q);
389	}	380	}
390		381
391	INTERFACE void	382	INTERFACE void
392	set_cdr (pointer p, pointer q)	383	set_cdr (pointer p, pointer q)
393	{	384	{
394	p->object.cons.cdr = q;	385	CELL(p)->object.cons.cdr = CELL (q);
395	}	386	}
396		387
397	INTERFACE pointer	388	INTERFACE pointer
398	pair_car (pointer p)	389	pair_car (pointer p)
399	{	390	{
…		…
404	pair_cdr (pointer p)	395	pair_cdr (pointer p)
405	{	396	{
406	return cdr (p);	397	return cdr (p);
407	}	398	}
408		399
409	INTERFACE INLINE int	400	INTERFACE int
410	is_symbol (pointer p)	401	is_symbol (pointer p)
411	{	402	{
412	return type (p) == T_SYMBOL;	403	return type (p) == T_SYMBOL;
413	}	404	}
414		405
415	INTERFACE INLINE char *	406	INTERFACE char *
416	symname (pointer p)	407	symname (pointer p)
417	{	408	{
418	return strvalue (car (p));	409	return strvalue (p);
419	}	410	}
420		411
421	#if USE_PLIST	412	#if USE_PLIST
		413	#error plists are broken because symbols are no longer pairs
		414	#define symprop(p) cdr(p)
422	SCHEME_EXPORT INLINE int	415	SCHEME_EXPORT int
423	hasprop (pointer p)	416	hasprop (pointer p)
424	{	417	{
425	return typeflag (p) & T_SYMBOL;	418	return typeflag (p) & T_SYMBOL;
426	}	419	}
427
428	# define symprop(p) cdr(p)
429	#endif	420	#endif
430		421
431	INTERFACE INLINE int	422	INTERFACE int
432	is_syntax (pointer p)	423	is_syntax (pointer p)
433	{	424	{
434	return typeflag (p) & T_SYNTAX;	425	return typeflag (p) & T_SYNTAX;
435	}	426	}
436		427
437	INTERFACE INLINE int	428	INTERFACE int
438	is_proc (pointer p)	429	is_proc (pointer p)
439	{	430	{
440	return type (p) == T_PROC;	431	return type (p) == T_PROC;
441	}	432	}
442		433
443	INTERFACE INLINE int	434	INTERFACE int
444	is_foreign (pointer p)	435	is_foreign (pointer p)
445	{	436	{
446	return type (p) == T_FOREIGN;	437	return type (p) == T_FOREIGN;
447	}	438	}
448		439
449	INTERFACE INLINE char *	440	INTERFACE char *
450	syntaxname (pointer p)	441	syntaxname (pointer p)
451	{	442	{
452	return strvalue (car (p));	443	return strvalue (p);
453	}	444	}
454		445
455	#define procnum(p) ivalue (p)	446	#define procnum(p) ivalue_unchecked (p)
456	static const char *procname (pointer x);	447	static const char *procname (pointer x);
457		448
458	INTERFACE INLINE int	449	INTERFACE int
459	is_closure (pointer p)	450	is_closure (pointer p)
460	{	451	{
461	return type (p) == T_CLOSURE;	452	return type (p) == T_CLOSURE;
462	}	453	}
463		454
464	INTERFACE INLINE int	455	INTERFACE int
465	is_macro (pointer p)	456	is_macro (pointer p)
466	{	457	{
467	return type (p) == T_MACRO;	458	return type (p) == T_MACRO;
468	}	459	}
469		460
470	INTERFACE INLINE pointer	461	INTERFACE pointer
471	closure_code (pointer p)	462	closure_code (pointer p)
472	{	463	{
473	return car (p);	464	return car (p);
474	}	465	}
475		466
476	INTERFACE INLINE pointer	467	INTERFACE pointer
477	closure_env (pointer p)	468	closure_env (pointer p)
478	{	469	{
479	return cdr (p);	470	return cdr (p);
480	}	471	}
481		472
482	INTERFACE INLINE int	473	INTERFACE int
483	is_continuation (pointer p)	474	is_continuation (pointer p)
484	{	475	{
485	return type (p) == T_CONTINUATION;	476	return type (p) == T_CONTINUATION;
486	}	477	}
487		478
488	#define cont_dump(p) cdr (p)	479	#define cont_dump(p) cdr (p)
489	#define set_cont_dump(p,v) set_cdr ((p), (v))	480	#define set_cont_dump(p,v) set_cdr ((p), (v))
490		481
491	/* To do: promise should be forced ONCE only */	482	/* To do: promise should be forced ONCE only */
492	INTERFACE INLINE int	483	INTERFACE int
493	is_promise (pointer p)	484	is_promise (pointer p)
494	{	485	{
495	return type (p) == T_PROMISE;	486	return type (p) == T_PROMISE;
496	}	487	}
497		488
498	INTERFACE INLINE int	489	INTERFACE int
499	is_environment (pointer p)	490	is_environment (pointer p)
500	{	491	{
501	return type (p) == T_ENVIRONMENT;	492	return type (p) == T_ENVIRONMENT;
502	}	493	}
503		494
…		…
509		500
510	#define is_mark(p) (typeflag (p) & T_MARK)	501	#define is_mark(p) (typeflag (p) & T_MARK)
511	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)	502	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
512	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	503	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
513		504
514	INTERFACE INLINE int	505	INTERFACE int
515	is_immutable (pointer p)	506	is_immutable (pointer p)
516	{	507	{
517	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	508	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
518	}	509	}
519		510
520	INTERFACE INLINE void	511	INTERFACE void
521	setimmutable (pointer p)	512	setimmutable (pointer p)
522	{	513	{
523	#if USE_ERROR_CHECKING	514	#if USE_ERROR_CHECKING
524	set_typeflag (p, typeflag (p) | T_IMMUTABLE);	515	set_typeflag (p, typeflag (p) | T_IMMUTABLE);
525	#endif	516	#endif
526	}	517	}
527		518
		519	/* Result is:
		520	proper list: length
		521	circular list: -1
		522	not even a pair: -2
		523	dotted list: -2 minus length before dot
		524	*/
		525	ecb_hot INTERFACE int
		526	list_length (SCHEME_P_ pointer a)
		527	{
		528	int i = 0;
		529	pointer slow, fast;
		530
		531	slow = fast = a;
		532
		533	while (1)
		534	{
		535	if (fast == NIL)
		536	return i;
		537
		538	if (!is_pair (fast))
		539	return -2 - i;
		540
		541	fast = cdr (fast);
		542	++i;
		543
		544	if (fast == NIL)
		545	return i;
		546
		547	if (!is_pair (fast))
		548	return -2 - i;
		549
		550	++i;
		551	fast = cdr (fast);
		552
		553	/* Safe because we would have already returned if `fast'
		554	encountered a non-pair. */
		555	slow = cdr (slow);
		556
		557	if (fast == slow)
		558	{
		559	/* the fast pointer has looped back around and caught up
		560	with the slow pointer, hence the structure is circular,
		561	not of finite length, and therefore not a list */
		562	return -1;
		563	}
		564	}
		565	}
		566
		567	INTERFACE int
		568	is_list (SCHEME_P_ pointer a)
		569	{
		570	return list_length (SCHEME_A_ a) >= 0;
		571	}
		572
528	#if USE_CHAR_CLASSIFIERS	573	#if USE_CHAR_CLASSIFIERS
529	static INLINE int	574	ecb_inline int
530	Cisalpha (int c)	575	Cisalpha (int c)
531	{	576	{
532	return isascii (c) && isalpha (c);	577	return isascii (c) && isalpha (c);
533	}	578	}
534		579
535	static INLINE int	580	ecb_inline int
536	Cisdigit (int c)	581	Cisdigit (int c)
537	{	582	{
538	return isascii (c) && isdigit (c);	583	return isascii (c) && isdigit (c);
539	}	584	}
540		585
541	static INLINE int	586	ecb_inline int
542	Cisspace (int c)	587	Cisspace (int c)
543	{	588	{
544	return isascii (c) && isspace (c);	589	return isascii (c) && isspace (c);
545	}	590	}
546		591
547	static INLINE int	592	ecb_inline int
548	Cisupper (int c)	593	Cisupper (int c)
549	{	594	{
550	return isascii (c) && isupper (c);	595	return isascii (c) && isupper (c);
551	}	596	}
552		597
553	static INLINE int	598	ecb_inline int
554	Cislower (int c)	599	Cislower (int c)
555	{	600	{
556	return isascii (c) && islower (c);	601	return isascii (c) && islower (c);
557	}	602	}
558	#endif	603	#endif
…		…
591	"gs",	636	"gs",
592	"rs",	637	"rs",
593	"us"	638	"us"
594	};	639	};
595		640
596	static int	641	ecb_cold static int
597	is_ascii_name (const char *name, int *pc)	642	is_ascii_name (const char *name, int *pc)
598	{	643	{
599	int i;	644	int i;
600		645
601	for (i = 0; i < 32; i++)	646	for (i = 0; i < 32; i++)
…		…
619	#endif	664	#endif
620		665
621	static int file_push (SCHEME_P_ const char *fname);	666	static int file_push (SCHEME_P_ const char *fname);
622	static void file_pop (SCHEME_P);	667	static void file_pop (SCHEME_P);
623	static int file_interactive (SCHEME_P);	668	static int file_interactive (SCHEME_P);
624	static INLINE int is_one_of (char *s, int c);	669	ecb_inline int is_one_of (const char *s, int c);
625	static int alloc_cellseg (SCHEME_P_ int n);	670	static int alloc_cellseg (SCHEME_P);
626	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);	671	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
627	static void finalize_cell (SCHEME_P_ pointer a);	672	static void finalize_cell (SCHEME_P_ pointer a);
628	static int count_consecutive_cells (pointer x, int needed);	673	static int count_consecutive_cells (pointer x, int needed);
629	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);
630	static pointer mk_number (SCHEME_P_ const num n);	675	static pointer mk_number (SCHEME_P_ const num n);
631	static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);	676	static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
…		…
646	static void mark (pointer a);	691	static void mark (pointer a);
647	static void gc (SCHEME_P_ pointer a, pointer b);	692	static void gc (SCHEME_P_ pointer a, pointer b);
648	static int basic_inchar (port *pt);	693	static int basic_inchar (port *pt);
649	static int inchar (SCHEME_P);	694	static int inchar (SCHEME_P);
650	static void backchar (SCHEME_P_ int c);	695	static void backchar (SCHEME_P_ int c);
651	static char *readstr_upto (SCHEME_P_ char *delim);	696	static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
652	static pointer readstrexp (SCHEME_P);	697	static pointer readstrexp (SCHEME_P_ char delim);
653	static INLINE int skipspace (SCHEME_P);	698	ecb_inline int skipspace (SCHEME_P);
654	static int token (SCHEME_P);	699	static int token (SCHEME_P);
655	static void printslashstring (SCHEME_P_ char *s, int len);	700	static void printslashstring (SCHEME_P_ char *s, int len);
656	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);
657	static void printatom (SCHEME_P_ pointer l, int f);	702	static void printatom (SCHEME_P_ pointer l, int f);
658	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	703	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
662	static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);	707	static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
663	static pointer revappend (SCHEME_P_ pointer a, pointer b);	708	static pointer revappend (SCHEME_P_ pointer a, pointer b);
664	static pointer ss_get_cont (SCHEME_P);	709	static pointer ss_get_cont (SCHEME_P);
665	static void ss_set_cont (SCHEME_P_ pointer cont);	710	static void ss_set_cont (SCHEME_P_ pointer cont);
666	static void dump_stack_mark (SCHEME_P);	711	static void dump_stack_mark (SCHEME_P);
667	static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);	712	static int opexe_0 (SCHEME_P_ enum scheme_opcodes op);
		713	static int opexe_1 (SCHEME_P_ enum scheme_opcodes op);
668	static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op);	714	static int opexe_2 (SCHEME_P_ enum scheme_opcodes op);
669	static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);	715	static int opexe_3 (SCHEME_P_ enum scheme_opcodes op);
670	static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);	716	static int opexe_4 (SCHEME_P_ enum scheme_opcodes op);
671	static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);	717	static int opexe_5 (SCHEME_P_ enum scheme_opcodes op);
672	static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);	718	static int opexe_6 (SCHEME_P_ enum scheme_opcodes op);
673	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);	719	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
674	static void assign_syntax (SCHEME_P_ const char *name);	720	static void assign_syntax (SCHEME_P_ const char *name);
675	static int syntaxnum (pointer p);	721	static int syntaxnum (pointer p);
676	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);	722	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
677		723
		724	static IVALUE
		725	ivalue (pointer x)
		726	{
		727	return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
		728	}
		729
		730	static RVALUE
		731	rvalue (pointer x)
		732	{
		733	return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
		734	}
		735
		736	INTERFACE num
		737	nvalue (pointer x)
		738	{
		739	num n;
		740
		741	num_set_fixnum (n, is_integer (x));
		742
		743	if (num_is_fixnum (n))
		744	num_set_ivalue (n, ivalue_unchecked (x));
		745	else
		746	num_set_rvalue (n, rvalue_unchecked (x));
		747
		748	return n;
		749	}
		750
678	static num	751	static num
679	num_add (num a, num b)	752	num_op (enum num_op op, num a, num b)
680	{	753	{
681	num ret;	754	num ret;
682		755
683	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	756	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
684		757
685	if (num_is_fixnum (ret))	758	if (num_is_fixnum (ret))
686	num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b));	759	{
		760	switch (op)
		761	{
		762	case NUM_ADD: a.ivalue += b.ivalue; break;
		763	case NUM_SUB: a.ivalue -= b.ivalue; break;
		764	case NUM_MUL: a.ivalue *= b.ivalue; break;
		765	case NUM_INTDIV: a.ivalue /= b.ivalue; break;
		766	}
		767
		768	num_set_ivalue (ret, a.ivalue);
		769	}
		770	#if USE_REAL
687	else	771	else
688	num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b));	772	{
		773	switch (op)
		774	{
		775	case NUM_ADD: a.rvalue += b.rvalue; break;
		776	case NUM_SUB: a.rvalue -= b.rvalue; break;
		777	case NUM_MUL: a.rvalue *= b.rvalue; break;
		778	case NUM_INTDIV: a.rvalue /= b.rvalue; break;
		779	}
689		780
690	return ret;	781	num_set_rvalue (ret, a.rvalue);
691	}	782	}
692		783	#endif
693	static num
694	num_mul (num a, num b)
695	{
696	num ret;
697
698	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
699
700	if (num_is_fixnum (ret))
701	num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b));
702	else
703	num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b));
704		784
705	return ret;	785	return ret;
706	}	786	}
707		787
708	static num	788	static num
709	num_div (num a, num b)	789	num_div (num a, num b)
710	{	790	{
711	num ret;	791	num ret;
712		792
713	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0);	793	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0);
714		794
715	if (num_is_fixnum (ret))	795	if (num_is_fixnum (ret))
716	num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));	796	num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b));
717	else	797	else
718	num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));	798	num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b));
719
720	return ret;
721	}
722
723	static num
724	num_intdiv (num a, num b)
725	{
726	num ret;
727
728	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
729
730	if (num_is_fixnum (ret))
731	num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
732	else
733	num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
734
735	return ret;
736	}
737
738	static num
739	num_sub (num a, num b)
740	{
741	num ret;
742
743	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
744
745	if (num_is_fixnum (ret))
746	num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b));
747	else
748	num_set_rvalue (ret, num_get_rvalue (a) - num_get_rvalue (b));
749		799
750	return ret;	800	return ret;
751	}	801	}
752		802
753	static num	803	static num
…		…
755	{	805	{
756	num ret;	806	num ret;
757	long e1, e2, res;	807	long e1, e2, res;
758		808
759	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	809	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
760	e1 = num_get_ivalue (a);	810	e1 = num_ivalue (a);
761	e2 = num_get_ivalue (b);	811	e2 = num_ivalue (b);
762	res = e1 % e2;	812	res = e1 % e2;
763		813
764	/* remainder should have same sign as second operand */	814	/* remainder should have same sign as second operand */
765	if (res > 0)	815	if (res > 0)
766	{	816	{
…		…
782	{	832	{
783	num ret;	833	num ret;
784	long e1, e2, res;	834	long e1, e2, res;
785		835
786	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	836	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
787	e1 = num_get_ivalue (a);	837	e1 = num_ivalue (a);
788	e2 = num_get_ivalue (b);	838	e2 = num_ivalue (b);
789	res = e1 % e2;	839	res = e1 % e2;
790		840
791	/* modulo should have same sign as second operand */	841	/* modulo should have same sign as second operand */
792	if (res * e2 < 0)	842	if (res * e2 < 0)
793	res += e2;	843	res += e2;
794		844
795	num_set_ivalue (ret, res);	845	num_set_ivalue (ret, res);
796	return ret;	846	return ret;
797	}	847	}
798		848
		849	/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
799	static int	850	static int
800	num_eq (num a, num b)	851	num_cmp (num a, num b)
801	{	852	{
		853	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
802	int ret;	854	int ret;
803	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
804		855
805	if (is_fixnum)	856	if (is_fixnum)
806	ret = num_get_ivalue (a) == num_get_ivalue (b);	857	{
		858	IVALUE av = num_ivalue (a);
		859	IVALUE bv = num_ivalue (b);
		860
		861	ret = av == bv ? 0 : av < bv ? -1 : +1;
		862	}
807	else	863	else
808	ret = num_get_rvalue (a) == num_get_rvalue (b);	864	{
		865	RVALUE av = num_rvalue (a);
		866	RVALUE bv = num_rvalue (b);
		867
		868	ret = av == bv ? 0 : av < bv ? -1 : +1;
		869	}
809		870
810	return ret;	871	return ret;
811	}	872	}
812
813
814	static int
815	num_gt (num a, num b)
816	{
817	int ret;
818	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
819
820	if (is_fixnum)
821	ret = num_get_ivalue (a) > num_get_ivalue (b);
822	else
823	ret = num_get_rvalue (a) > num_get_rvalue (b);
824
825	return ret;
826	}
827
828	static int
829	num_ge (num a, num b)
830	{
831	return !num_lt (a, b);
832	}
833
834	static int
835	num_lt (num a, num b)
836	{
837	int ret;
838	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
839
840	if (is_fixnum)
841	ret = num_get_ivalue (a) < num_get_ivalue (b);
842	else
843	ret = num_get_rvalue (a) < num_get_rvalue (b);
844
845	return ret;
846	}
847
848	static int
849	num_le (num a, num b)
850	{
851	return !num_gt (a, b);
852	}
853
854	#if USE_MATH
855
856	/* Round to nearest. Round to even if midway */
857	static double
858	round_per_R5RS (double x)
859	{
860	double fl = floor (x);
861	double ce = ceil (x);
862	double dfl = x - fl;
863	double dce = ce - x;
864
865	if (dfl > dce)
866	return ce;
867	else if (dfl < dce)
868	return fl;
869	else
870	{
871	if (fmod (fl, 2.0) == 0.0) /* I imagine this holds */
872	return fl;
873	else
874	return ce;
875	}
876	}
877	#endif
878		873
879	static int	874	static int
880	is_zero_rvalue (RVALUE x)	875	is_zero_rvalue (RVALUE x)
881	{	876	{
		877	return x == 0;
		878	#if 0
882	#if USE_REAL	879	#if USE_REAL
883	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */	880	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
884	#else	881	#else
885	return x == 0;	882	return x == 0;
886	#endif	883	#endif
		884	#endif
887	}	885	}
888		886
889	/* allocate new cell segment */	887	/* allocate new cell segment */
890	static int	888	ecb_cold static int
891	alloc_cellseg (SCHEME_P_ int n)	889	alloc_cellseg (SCHEME_P)
892	{	890	{
893	pointer newp;	891	struct cell *newp;
894	pointer last;	892	struct cell *last;
895	pointer p;	893	struct cell *p;
896	char *cp;	894	char *cp;
897	long i;	895	long i;
898	int k;	896	int k;
899		897
900	static int segsize = CELL_SEGSIZE >> 1;	898	static int segsize = CELL_SEGSIZE >> 1;
901	segsize <<= 1;	899	segsize <<= 1;
902		900
903	for (k = 0; k < n; k++)
904	{
905	if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
906	return k;
907
908	cp = malloc (segsize * sizeof (struct cell));	901	cp = malloc (segsize * sizeof (struct cell));
909		902
910	if (!cp && USE_ERROR_CHECKING)	903	if (!cp && USE_ERROR_CHECKING)
911	return k;	904	return k;
912		905
913	i = ++SCHEME_V->last_cell_seg;	906	i = ++SCHEME_V->last_cell_seg;
914	SCHEME_V->alloc_seg[i] = cp;	907	SCHEME_V->alloc_seg[i] = cp;
915		908
916	/* insert new segment in address order */	909	newp = (struct cell *)cp;
917	newp = (pointer)cp;
918	SCHEME_V->cell_seg[i] = newp;	910	SCHEME_V->cell_seg[i] = newp;
919	SCHEME_V->cell_segsize[i] = segsize;	911	SCHEME_V->cell_segsize[i] = segsize;
920
921	//TODO: insert, not swap
922	while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i])
923	{
924	p = SCHEME_V->cell_seg[i];
925	SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1];
926	SCHEME_V->cell_seg[i - 1] = p;
927
928	k = SCHEME_V->cell_segsize[i];
929	SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1];
930	SCHEME_V->cell_segsize[i - 1] = k;
931
932	--i;
933	}
934
935	SCHEME_V->fcells += segsize;	912	SCHEME_V->fcells += segsize;
936	last = newp + segsize - 1;	913	last = newp + segsize - 1;
937		914
938	for (p = newp; p <= last; p++)	915	for (p = newp; p <= last; p++)
939	{	916	{
		917	pointer cp = POINTER (p);
940	set_typeflag (p, T_FREE);	918	set_typeflag (cp, T_PAIR);
941	set_car (p, NIL);	919	set_car (cp, NIL);
942	set_cdr (p, p + 1);	920	set_cdr (cp, POINTER (p + 1));
943	}	921	}
944		922
945	/* insert new cells in address order on free list */
946	if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell)
947	{
948	set_cdr (last, SCHEME_V->free_cell);	923	set_cdr (POINTER (last), SCHEME_V->free_cell);
949	SCHEME_V->free_cell = newp;	924	SCHEME_V->free_cell = POINTER (newp);
950	}
951	else
952	{
953	p = SCHEME_V->free_cell;
954		925
955	while (cdr (p) != NIL && newp > cdr (p))
956	p = cdr (p);
957
958	set_cdr (last, cdr (p));
959	set_cdr (p, newp);
960	}
961	}
962
963	return n;	926	return 1;
964	}	927	}
965		928
966	/* get new cell. parameter a, b is marked by gc. */	929	/* get new cell. parameter a, b is marked by gc. */
967	static INLINE pointer	930	ecb_inline pointer
968	get_cell_x (SCHEME_P_ pointer a, pointer b)	931	get_cell_x (SCHEME_P_ pointer a, pointer b)
969	{	932	{
970	if (SCHEME_V->free_cell == NIL)	933	if (ecb_expect_false (SCHEME_V->free_cell == NIL))
971	{	934	{
972	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	935	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
973	return S_SINK;	936	return S_SINK;
974		937
975	if (SCHEME_V->free_cell == NIL)	938	if (SCHEME_V->free_cell == NIL)
976	{	939	{
977	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;
978		941
979	gc (SCHEME_A_ a, b);	942	gc (SCHEME_A_ a, b);
980		943
981	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)
982	{	945	{
983	/* 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 */
984	if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL)	947	if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
985	{	948	{
986	#if USE_ERROR_CHECKING	949	#if USE_ERROR_CHECKING
987	SCHEME_V->no_memory = 1;	950	SCHEME_V->no_memory = 1;
988	return S_SINK;	951	return S_SINK;
989	#endif	952	#endif
…		…
1001	}	964	}
1002	}	965	}
1003		966
1004	/* To retain recent allocs before interpreter knows about them -	967	/* To retain recent allocs before interpreter knows about them -
1005	Tehom */	968	Tehom */
1006		969	ecb_hot static void
1007	static void
1008	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)	970	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1009	{	971	{
1010	pointer holder = get_cell_x (SCHEME_A_ recent, extra);	972	pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1011		973
1012	set_typeflag (holder, T_PAIR);	974	set_typeflag (holder, T_PAIR);
…		…
1014	set_car (holder, recent);	976	set_car (holder, recent);
1015	set_cdr (holder, car (S_SINK));	977	set_cdr (holder, car (S_SINK));
1016	set_car (S_SINK, holder);	978	set_car (S_SINK, holder);
1017	}	979	}
1018		980
1019	static pointer	981	ecb_hot static pointer
1020	get_cell (SCHEME_P_ pointer a, pointer b)	982	get_cell (SCHEME_P_ pointer a, pointer b)
1021	{	983	{
1022	pointer cell = get_cell_x (SCHEME_A_ a, b);	984	pointer cell = get_cell_x (SCHEME_A_ a, b);
1023		985
1024	/* 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
…		…
1033	}	995	}
1034		996
1035	static pointer	997	static pointer
1036	get_vector_object (SCHEME_P_ uint32_t len, pointer init)	998	get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1037	{	999	{
1038	pointer v = get_cell_x (SCHEME_A_ 0, 0);	1000	pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1039	pointer *e = malloc (len * sizeof (pointer));	1001	pointer *e = malloc (len * sizeof (pointer));
1040		1002
1041	if (!e && USE_ERROR_CHECKING)	1003	if (!e && USE_ERROR_CHECKING)
1042	return S_SINK;	1004	return S_SINK;
1043		1005
1044	/* Record it as a vector so that gc understands it. */	1006	/* Record it as a vector so that gc understands it. */
1045	set_typeflag (v, T_VECTOR | T_ATOM);	1007	set_typeflag (v, T_VECTOR | T_ATOM);
1046		1008
1047	v->object.vector.vvalue = e;	1009	CELL(v)->object.vector.vvalue = e;
1048	v->object.vector.length = len;	1010	CELL(v)->object.vector.length = len;
1049	fill_vector (v, init);	1011	fill_vector (v, 0, init);
1050	push_recent_alloc (SCHEME_A_ v, NIL);	1012	push_recent_alloc (SCHEME_A_ v, NIL);
1051		1013
1052	return v;	1014	return v;
1053	}	1015	}
1054		1016
1055	static INLINE void	1017	ecb_inline void
1056	ok_to_freely_gc (SCHEME_P)	1018	ok_to_freely_gc (SCHEME_P)
1057	{	1019	{
1058	set_car (S_SINK, NIL);	1020	set_car (S_SINK, NIL);
1059	}	1021	}
1060		1022
…		…
1062	static void	1024	static void
1063	check_cell_alloced (pointer p, int expect_alloced)	1025	check_cell_alloced (pointer p, int expect_alloced)
1064	{	1026	{
1065	/* 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. */
1066	if (typeflag (p) & !expect_alloced)	1028	if (typeflag (p) & !expect_alloced)
1067	xwrstr ("Cell is already allocated!\n");	1029	putstr (SCHEME_A_ "Cell is already allocated!\n");
1068		1030
1069	if (!(typeflag (p)) & expect_alloced)	1031	if (!(typeflag (p)) & expect_alloced)
1070	xwrstr ("Cell is not allocated!\n");	1032	putstr (SCHEME_A_ "Cell is not allocated!\n");
1071	}	1033	}
1072		1034
1073	static void	1035	static void
1074	check_range_alloced (pointer p, int n, int expect_alloced)	1036	check_range_alloced (pointer p, int n, int expect_alloced)
1075	{	1037	{
…		…
1081	#endif	1043	#endif
1082		1044
1083	/* Medium level cell allocation */	1045	/* Medium level cell allocation */
1084		1046
1085	/* get new cons cell */	1047	/* get new cons cell */
1086	pointer	1048	ecb_hot pointer
1087	xcons (SCHEME_P_ pointer a, pointer b, int immutable)	1049	xcons (SCHEME_P_ pointer a, pointer b, int immutable)
1088	{	1050	{
1089	pointer x = get_cell (SCHEME_A_ a, b);	1051	pointer x = get_cell (SCHEME_A_ a, b);
1090		1052
1091	set_typeflag (x, T_PAIR);	1053	set_typeflag (x, T_PAIR);
…		…
1097	set_cdr (x, b);	1059	set_cdr (x, b);
1098		1060
1099	return x;	1061	return x;
1100	}	1062	}
1101		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
1102	/* ========== oblist implementation ========== */	1073	/* ========== oblist implementation ========== */
1103		1074
1104	#ifndef USE_OBJECT_LIST	1075	#ifndef USE_OBJECT_LIST
1105		1076
		1077	static int
1106	static int hash_fn (const char *key, int table_size);	1078	hash_fn (const char *key, int table_size)
		1079	{
		1080	const unsigned char *p = key;
		1081	uint32_t hash = 2166136261;
1107		1082
		1083	while (*p)
		1084	hash = (hash ^ *p++) * 16777619;
		1085
		1086	return hash % table_size;
		1087	}
		1088
1108	static pointer	1089	ecb_cold static pointer
1109	oblist_initial_value (SCHEME_P)	1090	oblist_initial_value (SCHEME_P)
1110	{	1091	{
1111	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */	1092	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1112	}	1093	}
1113		1094
1114	/* returns the new symbol */	1095	/* returns the new symbol */
1115	static pointer	1096	ecb_cold static pointer
1116	oblist_add_by_name (SCHEME_P_ const char *name)	1097	oblist_add_by_name (SCHEME_P_ const char *name)
1117	{	1098	{
1118	int location;	1099	pointer x = generate_symbol (SCHEME_A_ name);
1119
1120	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1121	set_typeflag (x, T_SYMBOL);
1122	setimmutable (car (x));
1123
1124	location = hash_fn (name, veclength (SCHEME_V->oblist));	1100	int location = hash_fn (name, veclength (SCHEME_V->oblist));
1125	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));	1101	vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1126	return x;	1102	return x;
1127	}	1103	}
1128		1104
1129	static INLINE pointer	1105	ecb_cold static pointer
1130	oblist_find_by_name (SCHEME_P_ const char *name)	1106	oblist_find_by_name (SCHEME_P_ const char *name)
1131	{	1107	{
1132	int location;	1108	int location;
1133	pointer x;	1109	pointer x;
1134	char *s;	1110	char *s;
1135		1111
1136	location = hash_fn (name, veclength (SCHEME_V->oblist));	1112	location = hash_fn (name, veclength (SCHEME_V->oblist));
1137		1113
1138	for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))	1114	for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1139	{	1115	{
1140	s = symname (car (x));	1116	s = symname (car (x));
1141		1117
1142	/* case-insensitive, per R5RS section 2 */	1118	/* case-insensitive, per R5RS section 2 */
1143	if (stricmp (name, s) == 0)	1119	if (stricmp (name, s) == 0)
…		…
1145	}	1121	}
1146		1122
1147	return NIL;	1123	return NIL;
1148	}	1124	}
1149		1125
1150	static pointer	1126	ecb_cold static pointer
1151	oblist_all_symbols (SCHEME_P)	1127	oblist_all_symbols (SCHEME_P)
1152	{	1128	{
1153	int i;	1129	int i;
1154	pointer x;	1130	pointer x;
1155	pointer ob_list = NIL;	1131	pointer ob_list = NIL;
1156		1132
1157	for (i = 0; i < veclength (SCHEME_V->oblist); i++)	1133	for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1158	for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))	1134	for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1159	ob_list = cons (x, ob_list);	1135	ob_list = cons (x, ob_list);
1160		1136
1161	return ob_list;	1137	return ob_list;
1162	}	1138	}
1163		1139
1164	#else	1140	#else
1165		1141
1166	static pointer	1142	ecb_cold static pointer
1167	oblist_initial_value (SCHEME_P)	1143	oblist_initial_value (SCHEME_P)
1168	{	1144	{
1169	return NIL;	1145	return NIL;
1170	}	1146	}
1171		1147
1172	static INLINE pointer	1148	ecb_cold static pointer
1173	oblist_find_by_name (SCHEME_P_ const char *name)	1149	oblist_find_by_name (SCHEME_P_ const char *name)
1174	{	1150	{
1175	pointer x;	1151	pointer x;
1176	char *s;	1152	char *s;
1177		1153
…		…
1186		1162
1187	return NIL;	1163	return NIL;
1188	}	1164	}
1189		1165
1190	/* returns the new symbol */	1166	/* returns the new symbol */
1191	static pointer	1167	ecb_cold static pointer
1192	oblist_add_by_name (SCHEME_P_ const char *name)	1168	oblist_add_by_name (SCHEME_P_ const char *name)
1193	{	1169	{
1194	pointer x;	1170	pointer x = generate_symbol (SCHEME_A_ name);
1195
1196	x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1197	set_typeflag (x, T_SYMBOL);
1198	setimmutable (car (x));
1199	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);	1171	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1200	return x;	1172	return x;
1201	}	1173	}
1202		1174
1203	static pointer	1175	ecb_cold static pointer
1204	oblist_all_symbols (SCHEME_P)	1176	oblist_all_symbols (SCHEME_P)
1205	{	1177	{
1206	return SCHEME_V->oblist;	1178	return SCHEME_V->oblist;
1207	}	1179	}
1208		1180
1209	#endif	1181	#endif
1210		1182
1211	#if USE_PORTS	1183	#if USE_PORTS
1212	static pointer	1184	ecb_cold static pointer
1213	mk_port (SCHEME_P_ port *p)	1185	mk_port (SCHEME_P_ port *p)
1214	{	1186	{
1215	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1187	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1216		1188
1217	set_typeflag (x, T_PORT | T_ATOM);	1189	set_typeflag (x, T_PORT | T_ATOM);
1218	x->object.port = p;	1190	set_port (x, p);
1219		1191
1220	return x;	1192	return x;
1221	}	1193	}
1222	#endif	1194	#endif
1223		1195
1224	pointer	1196	ecb_cold pointer
1225	mk_foreign_func (SCHEME_P_ foreign_func f)	1197	mk_foreign_func (SCHEME_P_ foreign_func f)
1226	{	1198	{
1227	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1199	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1228		1200
1229	set_typeflag (x, (T_FOREIGN | T_ATOM));	1201	set_typeflag (x, T_FOREIGN | T_ATOM);
1230	x->object.ff = f;	1202	CELL(x)->object.ff = f;
1231		1203
1232	return x;	1204	return x;
1233	}	1205	}
1234		1206
1235	INTERFACE pointer	1207	INTERFACE pointer
1236	mk_character (SCHEME_P_ int c)	1208	mk_character (SCHEME_P_ int c)
1237	{	1209	{
1238	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1210	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1239		1211
1240	set_typeflag (x, (T_CHARACTER | T_ATOM));	1212	set_typeflag (x, T_CHARACTER | T_ATOM);
1241	ivalue_unchecked (x) = c & 0xff;	1213	set_ivalue (x, c & 0xff);
1242	set_num_integer (x);	1214
1243	return x;	1215	return x;
1244	}	1216	}
1245		1217
1246	/* get number atom (integer) */	1218	/* get number atom (integer) */
1247	INTERFACE pointer	1219	INTERFACE pointer
1248	mk_integer (SCHEME_P_ long num)	1220	mk_integer (SCHEME_P_ long n)
1249	{	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	{
1250	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1232	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1251		1233
1252	set_typeflag (x, (T_NUMBER | T_ATOM));	1234	set_typeflag (x, T_INTEGER | T_ATOM);
1253	ivalue_unchecked (x) = num;	1235	setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
1254	set_num_integer (x);	1236	set_ivalue (x, n);
		1237
		1238	*pp = x;
		1239	}
		1240
1255	return x;	1241	return *pp;
1256	}	1242	}
1257		1243
1258	INTERFACE pointer	1244	INTERFACE pointer
1259	mk_real (SCHEME_P_ RVALUE n)	1245	mk_real (SCHEME_P_ RVALUE n)
1260	{	1246	{
		1247	#if USE_REAL
1261	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1248	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1262		1249
1263	set_typeflag (x, (T_NUMBER | T_ATOM));	1250	set_typeflag (x, T_REAL | T_ATOM);
1264	rvalue_unchecked (x) = n;	1251	set_rvalue (x, n);
1265	set_num_real (x);	1252
1266	return x;	1253	return x;
		1254	#else
		1255	return mk_integer (SCHEME_A_ n);
		1256	#endif
1267	}	1257	}
1268		1258
1269	static pointer	1259	static pointer
1270	mk_number (SCHEME_P_ const num n)	1260	mk_number (SCHEME_P_ const num n)
1271	{	1261	{
		1262	#if USE_REAL
1272	if (num_is_fixnum (n))	1263	return num_is_fixnum (n)
		1264	? mk_integer (SCHEME_A_ num_ivalue (n))
		1265	: mk_real (SCHEME_A_ num_rvalue (n));
		1266	#else
1273	return mk_integer (SCHEME_A_ num_get_ivalue (n));	1267	return mk_integer (SCHEME_A_ num_ivalue (n));
1274	else	1268	#endif
1275	return mk_real (SCHEME_A_ num_get_rvalue (n));
1276	}	1269	}
1277		1270
1278	/* allocate name to string area */	1271	/* allocate name to string area */
1279	static char *	1272	static char *
1280	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)	1273	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
…		…
1286	SCHEME_V->no_memory = 1;	1279	SCHEME_V->no_memory = 1;
1287	return SCHEME_V->strbuff;	1280	return SCHEME_V->strbuff;
1288	}	1281	}
1289		1282
1290	if (str)	1283	if (str)
1291	{	1284	memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
1292	int l = strlen (str);
1293
1294	if (l > len_str)
1295	l = len_str;
1296
1297	memcpy (q, str, l);
1298	q[l] = 0;
1299	}
1300	else	1285	else
1301	{
1302	memset (q, fill, len_str);	1286	memset (q, fill, len_str);
		1287
1303	q[len_str] = 0;	1288	q[len_str] = 0;
1304	}
1305		1289
1306	return q;	1290	return q;
1307	}	1291	}
1308		1292
1309	INTERFACE pointer	1293	INTERFACE pointer
…		…
1323	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1307	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1324		1308
1325	set_typeflag (x, T_STRING | T_ATOM);	1309	set_typeflag (x, T_STRING | T_ATOM);
1326	strvalue (x) = store_string (SCHEME_A_ len, str, 0);	1310	strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1327	strlength (x) = len;	1311	strlength (x) = len;
		1312
1328	return x;	1313	return x;
1329	}	1314	}
1330		1315
1331	INTERFACE pointer	1316	INTERFACE pointer
1332	mk_string (SCHEME_P_ const char *str)	1317	mk_string (SCHEME_P_ const char *str)
…		…
1339	{	1324	{
1340	return get_vector_object (SCHEME_A_ len, NIL);	1325	return get_vector_object (SCHEME_A_ len, NIL);
1341	}	1326	}
1342		1327
1343	INTERFACE void	1328	INTERFACE void
1344	fill_vector (pointer vec, pointer obj)	1329	fill_vector (pointer vec, uint32_t start, pointer obj)
1345	{	1330	{
1346	int i;	1331	int i;
1347		1332
1348	for (i = 0; i < vec->object.vector.length; i++)	1333	for (i = start; i < veclength (vec); i++)
1349	vecvalue (vec)[i] = obj;	1334	vecvalue (vec)[i] = obj;
1350	}	1335	}
1351		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);
		1344	}
		1345
1352	INTERFACE pointer	1346	INTERFACE pointer
1353	vector_elem (pointer vec, uint32_t ielem)	1347	vector_get (pointer vec, uint32_t ielem)
1354	{	1348	{
1355	return vecvalue(vec)[ielem];	1349	return vecvalue(vec)[ielem];
1356	}	1350	}
1357		1351
1358	INTERFACE void	1352	INTERFACE void
1359	set_vector_elem (pointer vec, uint32_t ielem, pointer a)	1353	vector_set (pointer vec, uint32_t ielem, pointer a)
1360	{	1354	{
1361	vecvalue(vec)[ielem] = a;	1355	vecvalue(vec)[ielem] = a;
1362	}	1356	}
1363		1357
1364	/* get new symbol */	1358	/* get new symbol */
…		…
1372	x = oblist_add_by_name (SCHEME_A_ name);	1366	x = oblist_add_by_name (SCHEME_A_ name);
1373		1367
1374	return x;	1368	return x;
1375	}	1369	}
1376		1370
1377	INTERFACE pointer	1371	ecb_cold INTERFACE pointer
1378	gensym (SCHEME_P)	1372	gensym (SCHEME_P)
1379	{	1373	{
1380	pointer x;	1374	pointer x;
1381
1382	for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1383	{
1384	char name[40] = "gensym-";	1375	char name[40] = "gensym-";
1385	xnum (name + 7, SCHEME_V->gensym_cnt);	1376	xnum (name + 7, ++SCHEME_V->gensym_cnt);
1386		1377
1387	/* first check oblist */	1378	return generate_symbol (SCHEME_A_ name);
1388	x = oblist_find_by_name (SCHEME_A_ name);	1379	}
1389		1380
1390	if (x == NIL)	1381	static int
1391	{	1382	is_gensym (SCHEME_P_ pointer x)
1392	x = oblist_add_by_name (SCHEME_A_ name);	1383	{
1393	return x;	1384	return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1394	}
1395	}
1396
1397	return NIL;
1398	}	1385	}
1399		1386
1400	/* make symbol or number atom from string */	1387	/* make symbol or number atom from string */
1401	static pointer	1388	ecb_cold static pointer
1402	mk_atom (SCHEME_P_ char *q)	1389	mk_atom (SCHEME_P_ char *q)
1403	{	1390	{
1404	char c, *p;	1391	char c, *p;
1405	int has_dec_point = 0;	1392	int has_dec_point = 0;
1406	int has_fp_exp = 0;	1393	int has_fp_exp = 0;
…		…
1456	}	1443	}
1457	else if ((c == 'e') || (c == 'E'))	1444	else if ((c == 'e') || (c == 'E'))
1458	{	1445	{
1459	if (!has_fp_exp)	1446	if (!has_fp_exp)
1460	{	1447	{
1461	has_dec_point = 1; /* decimal point illegal	1448	has_dec_point = 1; /* decimal point illegal from now on */
1462	from now on */
1463	p++;	1449	p++;
1464		1450
1465	if ((*p == '-') || (*p == '+') || isdigit (*p))	1451	if ((*p == '-') || (*p == '+') || isdigit (*p))
1466	continue;	1452	continue;
1467	}	1453	}
…		…
1478		1464
1479	return mk_integer (SCHEME_A_ strtol (q, 0, 10));	1465	return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1480	}	1466	}
1481		1467
1482	/* make constant */	1468	/* make constant */
1483	static pointer	1469	ecb_cold static pointer
1484	mk_sharp_const (SCHEME_P_ char *name)	1470	mk_sharp_const (SCHEME_P_ char *name)
1485	{	1471	{
1486	long x;
1487	char tmp[STRBUFFSIZE];
1488
1489	if (!strcmp (name, "t"))	1472	if (!strcmp (name, "t"))
1490	return S_T;	1473	return S_T;
1491	else if (!strcmp (name, "f"))	1474	else if (!strcmp (name, "f"))
1492	return S_F;	1475	return S_F;
1493	else if (*name == '\\') /* #\w (character) */	1476	else if (*name == '\\') /* #\w (character) */
1494	{	1477	{
1495	int c = 0;	1478	int c;
1496		1479
		1480	// TODO: optimise
1497	if (stricmp (name + 1, "space") == 0)	1481	if (stricmp (name + 1, "space") == 0)
1498	c = ' ';	1482	c = ' ';
1499	else if (stricmp (name + 1, "newline") == 0)	1483	else if (stricmp (name + 1, "newline") == 0)
1500	c = '\n';	1484	c = '\n';
1501	else if (stricmp (name + 1, "return") == 0)	1485	else if (stricmp (name + 1, "return") == 0)
1502	c = '\r';	1486	c = '\r';
1503	else if (stricmp (name + 1, "tab") == 0)	1487	else if (stricmp (name + 1, "tab") == 0)
1504	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;
1505	else if (name[1] == 'x' && name[2] != 0)	1499	else if (name[1] == 'x' && name[2] != 0)
1506	{	1500	{
1507	int c1 = strtol (name + 2, 0, 16);	1501	long c1 = strtol (name + 2, 0, 16);
1508		1502
1509	if (c1 <= UCHAR_MAX)	1503	if (0 <= c1 && c1 <= UCHAR_MAX)
1510	c = c1;	1504	c = c1;
1511	else	1505	else
1512	return NIL;	1506	return NIL;
1513		1507	}
1514	#if USE_ASCII_NAMES	1508	#if USE_ASCII_NAMES
1515	}
1516	else if (is_ascii_name (name + 1, &c))	1509	else if (is_ascii_name (name + 1, &c))
1517	{
1518	/* nothing */	1510	/* nothing */;
1519	#endif	1511	#endif
1520	}
1521	else if (name[2] == 0)	1512	else if (name[2] == 0)
1522	c = name[1];	1513	c = name[1];
1523	else	1514	else
1524	return NIL;	1515	return NIL;
1525		1516
…		…
1538	}	1529	}
1539	}	1530	}
1540		1531
1541	/* ========== garbage collector ========== */	1532	/* ========== garbage collector ========== */
1542		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	}
		1552
1543	/*--	1553	/*--
1544	* 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,
1545	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,	1555	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1546	* for marking.	1556	* for marking.
		1557	*
		1558	* The exception is vectors - vectors are currently marked recursively,
		1559	* which is inherited form tinyscheme and could be fixed by having another
		1560	* word of context in the vector
1547	*/	1561	*/
1548	static void	1562	ecb_hot static void
1549	mark (pointer a)	1563	mark (pointer a)
1550	{	1564	{
1551	pointer t, q, p;	1565	pointer t, q, p;
1552		1566
1553	t = 0;	1567	t = 0;
1554	p = a;	1568	p = a;
1555	E2:	1569	E2:
1556	setmark (p);	1570	setmark (p);
1557		1571
1558	if (is_vector (p))	1572	if (ecb_expect_false (is_vector (p)))
1559	{	1573	{
1560	int i;	1574	int i;
1561		1575
1562	for (i = 0; i < p->object.vector.length; i++)	1576	for (i = 0; i < veclength (p); i++)
1563	mark (vecvalue (p)[i]);	1577	mark (vecvalue (p)[i]);
1564	}	1578	}
1565		1579
1566	if (is_atom (p))	1580	if (is_atom (p))
1567	goto E6;	1581	goto E6;
…		…
1610	p = q;	1624	p = q;
1611	goto E6;	1625	goto E6;
1612	}	1626	}
1613	}	1627	}
1614		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
1615	/* garbage collection. parameter a, b is marked. */	1671	/* garbage collection. parameter a, b is marked. */
1616	static void	1672	ecb_cold static void
1617	gc (SCHEME_P_ pointer a, pointer b)	1673	gc (SCHEME_P_ pointer a, pointer b)
1618	{	1674	{
1619	pointer p;
1620	int i;	1675	int i;
1621		1676
1622	if (SCHEME_V->gc_verbose)	1677	if (SCHEME_V->gc_verbose)
1623	putstr (SCHEME_A_ "gc...");	1678	putstr (SCHEME_A_ "gc...");
1624		1679
…		…
1640	/* Mark recent objects the interpreter doesn't know about yet. */	1695	/* Mark recent objects the interpreter doesn't know about yet. */
1641	mark (car (S_SINK));	1696	mark (car (S_SINK));
1642	/* Mark any older stuff above nested C calls */	1697	/* Mark any older stuff above nested C calls */
1643	mark (SCHEME_V->c_nest);	1698	mark (SCHEME_V->c_nest);
1644		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
1645	/* mark variables a, b */	1707	/* mark variables a, b */
1646	mark (a);	1708	mark (a);
1647	mark (b);	1709	mark (b);
1648		1710
1649	/* garbage collect */	1711	/* garbage collect */
1650	clrmark (NIL);	1712	clrmark (NIL);
1651	SCHEME_V->fcells = 0;	1713	SCHEME_V->fcells = 0;
1652	SCHEME_V->free_cell = NIL;	1714	SCHEME_V->free_cell = NIL;
1653		1715
1654	/* free-list is kept sorted by address so as to maintain consecutive
1655	ranges, if possible, for use with vectors. Here we scan the cells
1656	(which are also kept sorted by address) downwards to build the
1657	free-list in sorted order.
1658	*/
1659	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1660	{
1661	p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1662
1663	while (--p >= SCHEME_V->cell_seg[i])
1664	{
1665	if (is_mark (p))
1666	clrmark (p);
1667	else
1668	{
1669	/* reclaim cell */
1670	if (typeflag (p) != T_FREE)
1671	{
1672	finalize_cell (SCHEME_A_ p);
1673	set_typeflag (p, T_FREE);
1674	set_car (p, NIL);
1675	}
1676
1677	++SCHEME_V->fcells;
1678	set_cdr (p, SCHEME_V->free_cell);
1679	SCHEME_V->free_cell = p;
1680	}
1681	}
1682	}
1683
1684	if (SCHEME_V->gc_verbose)	1716	if (SCHEME_V->gc_verbose)
1685	xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");	1717	putstr (SCHEME_A_ "freeing...");
1686	}
1687		1718
1688	static void	1719	gc_free (SCHEME_A);
1689	finalize_cell (SCHEME_P_ pointer a)
1690	{
1691	if (is_string (a))
1692	free (strvalue (a));
1693	else if (is_vector (a))
1694	free (vecvalue (a));
1695	#if USE_PORTS
1696	else if (is_port (a))
1697	{
1698	if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1699	port_close (SCHEME_A_ a, port_input | port_output);
1700
1701	free (a->object.port);
1702	}
1703	#endif
1704	}	1720	}
1705		1721
1706	/* ========== Routines for Reading ========== */	1722	/* ========== Routines for Reading ========== */
1707		1723
1708	static int	1724	ecb_cold static int
1709	file_push (SCHEME_P_ const char *fname)	1725	file_push (SCHEME_P_ const char *fname)
1710	{	1726	{
1711	#if USE_PORTS	1727	#if USE_PORTS
1712	int fin;	1728	int fin;
1713		1729
…		…
1722	SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;	1738	SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1723	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;
1724	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;
1725	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;
1726	SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;	1742	SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1727	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);
1728		1744
1729	#if SHOW_ERROR_LINE	1745	#if SHOW_ERROR_LINE
1730	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;
1731		1747
1732	if (fname)	1748	if (fname)
…		…
1739	#else	1755	#else
1740	return 1;	1756	return 1;
1741	#endif	1757	#endif
1742	}	1758	}
1743		1759
1744	static void	1760	ecb_cold static void
1745	file_pop (SCHEME_P)	1761	file_pop (SCHEME_P)
1746	{	1762	{
1747	if (SCHEME_V->file_i != 0)	1763	if (SCHEME_V->file_i != 0)
1748	{	1764	{
1749	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];	1765	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1750	#if USE_PORTS	1766	#if USE_PORTS
1751	port_close (SCHEME_A_ SCHEME_V->loadport, port_input);	1767	port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1752	#endif	1768	#endif
1753	SCHEME_V->file_i--;	1769	SCHEME_V->file_i--;
1754	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);
1755	}	1771	}
1756	}	1772	}
1757		1773
1758	static int	1774	ecb_cold static int
1759	file_interactive (SCHEME_P)	1775	file_interactive (SCHEME_P)
1760	{	1776	{
1761	#if USE_PORTS	1777	#if USE_PORTS
1762	return SCHEME_V->file_i == 0	1778	return SCHEME_V->file_i == 0
1763	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO	1779	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1764	&& (SCHEME_V->inport->object.port->kind & port_file);	1780	&& (port (SCHEME_V->inport)->kind & port_file);
1765	#else	1781	#else
1766	return 0;	1782	return 0;
1767	#endif	1783	#endif
1768	}	1784	}
1769		1785
1770	#if USE_PORTS	1786	#if USE_PORTS
1771	static port *	1787	ecb_cold static port *
1772	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)	1788	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1773	{	1789	{
1774	int fd;	1790	int fd;
1775	int flags;	1791	int flags;
1776	char *rw;	1792	char *rw;
…		…
1799	# endif	1815	# endif
1800		1816
1801	return pt;	1817	return pt;
1802	}	1818	}
1803		1819
1804	static pointer	1820	ecb_cold static pointer
1805	port_from_filename (SCHEME_P_ const char *fn, int prop)	1821	port_from_filename (SCHEME_P_ const char *fn, int prop)
1806	{	1822	{
1807	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);	1823	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1808		1824
1809	if (!pt && USE_ERROR_CHECKING)	1825	if (!pt && USE_ERROR_CHECKING)
1810	return NIL;	1826	return NIL;
1811		1827
1812	return mk_port (SCHEME_A_ pt);	1828	return mk_port (SCHEME_A_ pt);
1813	}	1829	}
1814		1830
1815	static port *	1831	ecb_cold static port *
1816	port_rep_from_file (SCHEME_P_ int f, int prop)	1832	port_rep_from_file (SCHEME_P_ int f, int prop)
1817	{	1833	{
1818	port *pt = malloc (sizeof *pt);	1834	port *pt = malloc (sizeof *pt);
1819		1835
1820	if (!pt && USE_ERROR_CHECKING)	1836	if (!pt && USE_ERROR_CHECKING)
…		…
1825	pt->rep.stdio.file = f;	1841	pt->rep.stdio.file = f;
1826	pt->rep.stdio.closeit = 0;	1842	pt->rep.stdio.closeit = 0;
1827	return pt;	1843	return pt;
1828	}	1844	}
1829		1845
1830	static pointer	1846	ecb_cold static pointer
1831	port_from_file (SCHEME_P_ int f, int prop)	1847	port_from_file (SCHEME_P_ int f, int prop)
1832	{	1848	{
1833	port *pt = port_rep_from_file (SCHEME_A_ f, prop);	1849	port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1834		1850
1835	if (!pt && USE_ERROR_CHECKING)	1851	if (!pt && USE_ERROR_CHECKING)
1836	return NIL;	1852	return NIL;
1837		1853
1838	return mk_port (SCHEME_A_ pt);	1854	return mk_port (SCHEME_A_ pt);
1839	}	1855	}
1840		1856
1841	static port *	1857	ecb_cold static port *
1842	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)
1843	{	1859	{
1844	port *pt = malloc (sizeof (port));	1860	port *pt = malloc (sizeof (port));
1845		1861
1846	if (!pt && USE_ERROR_CHECKING)	1862	if (!pt && USE_ERROR_CHECKING)
…		…
1852	pt->rep.string.curr = start;	1868	pt->rep.string.curr = start;
1853	pt->rep.string.past_the_end = past_the_end;	1869	pt->rep.string.past_the_end = past_the_end;
1854	return pt;	1870	return pt;
1855	}	1871	}
1856		1872
1857	static pointer	1873	ecb_cold static pointer
1858	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)
1859	{	1875	{
1860	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);
1861		1877
1862	if (!pt && USE_ERROR_CHECKING)	1878	if (!pt && USE_ERROR_CHECKING)
…		…
1865	return mk_port (SCHEME_A_ pt);	1881	return mk_port (SCHEME_A_ pt);
1866	}	1882	}
1867		1883
1868	# define BLOCK_SIZE 256	1884	# define BLOCK_SIZE 256
1869		1885
1870	static port *	1886	ecb_cold static port *
1871	port_rep_from_scratch (SCHEME_P)	1887	port_rep_from_scratch (SCHEME_P)
1872	{	1888	{
1873	char *start;	1889	char *start;
1874	port *pt = malloc (sizeof (port));	1890	port *pt = malloc (sizeof (port));
1875		1891
…		…
1889	pt->rep.string.curr = start;	1905	pt->rep.string.curr = start;
1890	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;	1906	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1891	return pt;	1907	return pt;
1892	}	1908	}
1893		1909
1894	static pointer	1910	ecb_cold static pointer
1895	port_from_scratch (SCHEME_P)	1911	port_from_scratch (SCHEME_P)
1896	{	1912	{
1897	port *pt = port_rep_from_scratch (SCHEME_A);	1913	port *pt = port_rep_from_scratch (SCHEME_A);
1898		1914
1899	if (!pt && USE_ERROR_CHECKING)	1915	if (!pt && USE_ERROR_CHECKING)
1900	return NIL;	1916	return NIL;
1901		1917
1902	return mk_port (SCHEME_A_ pt);	1918	return mk_port (SCHEME_A_ pt);
1903	}	1919	}
1904		1920
1905	static void	1921	ecb_cold static void
1906	port_close (SCHEME_P_ pointer p, int flag)	1922	port_close (SCHEME_P_ pointer p, int flag)
1907	{	1923	{
1908	port *pt = p->object.port;	1924	port *pt = port (p);
1909		1925
1910	pt->kind &= ~flag;	1926	pt->kind &= ~flag;
1911		1927
1912	if ((pt->kind & (port_input | port_output)) == 0)	1928	if ((pt->kind & (port_input | port_output)) == 0)
1913	{	1929	{
…		…
1934	/* get new character from input file */	1950	/* get new character from input file */
1935	static int	1951	static int
1936	inchar (SCHEME_P)	1952	inchar (SCHEME_P)
1937	{	1953	{
1938	int c;	1954	int c;
1939	port *pt;	1955	port *pt = port (SCHEME_V->inport);
1940
1941	pt = SCHEME_V->inport->object.port;
1942		1956
1943	if (pt->kind & port_saw_EOF)	1957	if (pt->kind & port_saw_EOF)
1944	return EOF;	1958	return EOF;
1945		1959
1946	c = basic_inchar (pt);	1960	c = basic_inchar (pt);
…		…
2013	port *pt;	2027	port *pt;
2014		2028
2015	if (c == EOF)	2029	if (c == EOF)
2016	return;	2030	return;
2017		2031
2018	pt = SCHEME_V->inport->object.port;	2032	pt = port (SCHEME_V->inport);
2019	pt->unget = c;	2033	pt->unget = c;
2020	#else	2034	#else
2021	if (c == EOF)	2035	if (c == EOF)
2022	return;	2036	return;
2023		2037
2024	ungot = c;	2038	ungot = c;
2025	#endif	2039	#endif
2026	}	2040	}
2027		2041
2028	#if USE_PORTS	2042	#if USE_PORTS
2029	static int	2043	ecb_cold static int
2030	realloc_port_string (SCHEME_P_ port *p)	2044	realloc_port_string (SCHEME_P_ port *p)
2031	{	2045	{
2032	char *start = p->rep.string.start;	2046	char *start = p->rep.string.start;
2033	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;
2034	char *str = malloc (new_size);	2048	char *str = malloc (new_size);
…		…
2047	else	2061	else
2048	return 0;	2062	return 0;
2049	}	2063	}
2050	#endif	2064	#endif
2051		2065
2052	INTERFACE void	2066	ecb_cold INTERFACE void
2053	putstr (SCHEME_P_ const char *s)	2067	putstr (SCHEME_P_ const char *s)
2054	{	2068	{
2055	#if USE_PORTS	2069	#if USE_PORTS
2056	port *pt = SCHEME_V->outport->object.port;	2070	port *pt = port (SCHEME_V->outport);
2057		2071
2058	if (pt->kind & port_file)	2072	if (pt->kind & port_file)
2059	write (pt->rep.stdio.file, s, strlen (s));	2073	write (pt->rep.stdio.file, s, strlen (s));
2060	else	2074	else
2061	for (; *s; s++)	2075	for (; *s; s++)
…		…
2063	*pt->rep.string.curr++ = *s;	2077	*pt->rep.string.curr++ = *s;
2064	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))
2065	*pt->rep.string.curr++ = *s;	2079	*pt->rep.string.curr++ = *s;
2066		2080
2067	#else	2081	#else
2068	xwrstr (s);	2082	write (pt->rep.stdio.file, s, strlen (s));
2069	#endif	2083	#endif
2070	}	2084	}
2071		2085
2072	static void	2086	ecb_cold static void
2073	putchars (SCHEME_P_ const char *s, int len)	2087	putchars (SCHEME_P_ const char *s, int len)
2074	{	2088	{
2075	#if USE_PORTS	2089	#if USE_PORTS
2076	port *pt = SCHEME_V->outport->object.port;	2090	port *pt = port (SCHEME_V->outport);
2077		2091
2078	if (pt->kind & port_file)	2092	if (pt->kind & port_file)
2079	write (pt->rep.stdio.file, s, len);	2093	write (pt->rep.stdio.file, s, len);
2080	else	2094	else
2081	{	2095	{
…		…
2091	#else	2105	#else
2092	write (1, s, len);	2106	write (1, s, len);
2093	#endif	2107	#endif
2094	}	2108	}
2095		2109
2096	INTERFACE void	2110	ecb_cold INTERFACE void
2097	putcharacter (SCHEME_P_ int c)	2111	putcharacter (SCHEME_P_ int c)
2098	{	2112	{
2099	#if USE_PORTS	2113	#if USE_PORTS
2100	port *pt = SCHEME_V->outport->object.port;	2114	port *pt = port (SCHEME_V->outport);
2101		2115
2102	if (pt->kind & port_file)	2116	if (pt->kind & port_file)
2103	{	2117	{
2104	char cc = c;	2118	char cc = c;
2105	write (pt->rep.stdio.file, &cc, 1);	2119	write (pt->rep.stdio.file, &cc, 1);
…		…
2117	write (1, &c, 1);	2131	write (1, &c, 1);
2118	#endif	2132	#endif
2119	}	2133	}
2120		2134
2121	/* read characters up to delimiter, but cater to character constants */	2135	/* read characters up to delimiter, but cater to character constants */
2122	static char *	2136	ecb_cold static char *
2123	readstr_upto (SCHEME_P_ char *delim)	2137	readstr_upto (SCHEME_P_ int skip, const char *delim)
2124	{	2138	{
2125	char *p = SCHEME_V->strbuff;	2139	char *p = SCHEME_V->strbuff + skip;
2126		2140
2127	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))));
2128		2142
2129	if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')	2143	if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2130	*p = 0;	2144	*p = 0;
…		…
2136		2150
2137	return SCHEME_V->strbuff;	2151	return SCHEME_V->strbuff;
2138	}	2152	}
2139		2153
2140	/* read string expression "xxx...xxx" */	2154	/* read string expression "xxx...xxx" */
2141	static pointer	2155	ecb_cold static pointer
2142	readstrexp (SCHEME_P)	2156	readstrexp (SCHEME_P_ char delim)
2143	{	2157	{
2144	char *p = SCHEME_V->strbuff;	2158	char *p = SCHEME_V->strbuff;
2145	int c;	2159	int c;
2146	int c1 = 0;	2160	int c1 = 0;
2147	enum
2148	{ 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;
2149		2162
2150	for (;;)	2163	for (;;)
2151	{	2164	{
2152	c = inchar (SCHEME_A);	2165	c = inchar (SCHEME_A);
2153		2166
…		…
2155	return S_F;	2168	return S_F;
2156		2169
2157	switch (state)	2170	switch (state)
2158	{	2171	{
2159	case st_ok:	2172	case st_ok:
2160	switch (c)	2173	if (ecb_expect_false (c == delim))
2161	{
2162	case '\\':
2163	state = st_bsl;
2164	break;
2165
2166	case '"':
2167	*p = 0;
2168	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);
2169		2175
2170	default:	2176	if (ecb_expect_false (c == '\\'))
		2177	state = st_bsl;
		2178	else
2171	*p++ = c;	2179	*p++ = c;
2172	break;
2173	}
2174		2180
2175	break;	2181	break;
2176		2182
2177	case st_bsl:	2183	case st_bsl:
2178	switch (c)	2184	switch (c)
…		…
2187	case '7':	2193	case '7':
2188	state = st_oct1;	2194	state = st_oct1;
2189	c1 = c - '0';	2195	c1 = c - '0';
2190	break;	2196	break;
2191		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
2192	case 'x':	2206	case 'x':
2193	case 'X':	2207	case 'X':
2194	state = st_x1;	2208	state = st_x1;
2195	c1 = 0;	2209	c1 = 0;
2196	break;	2210	break;
2197		2211
2198	case 'n':
2199	*p++ = '\n';
2200	state = st_ok;
2201	break;
2202
2203	case 't':
2204	*p++ = '\t';
2205	state = st_ok;
2206	break;
2207
2208	case 'r':
2209	*p++ = '\r';
2210	state = st_ok;
2211	break;
2212
2213	case '"':
2214	*p++ = '"';
2215	state = st_ok;
2216	break;
2217
2218	default:	2212	default:
2219	*p++ = c;	2213	*p++ = c;
2220	state = st_ok;	2214	state = st_ok;
2221	break;	2215	break;
2222	}	2216	}
2223		2217
2224	break;	2218	break;
2225		2219
2226	case st_x1:	2220	case st_x1:
2227	case st_x2:	2221	case st_x2:
2228	c = toupper (c);	2222	c = tolower (c);
2229		2223
2230	if (c >= '0' && c <= 'F')	2224	if (c >= '0' && c <= '9')
2231	{
2232	if (c <= '9')
2233	c1 = (c1 << 4) + c - '0';	2225	c1 = (c1 << 4) + c - '0';
2234	else	2226	else if (c >= 'a' && c <= 'f')
2235	c1 = (c1 << 4) + c - 'A' + 10;	2227	c1 = (c1 << 4) + c - 'a' + 10;
2236
2237	if (state == st_x1)
2238	state = st_x2;
2239	else
2240	{
2241	*p++ = c1;
2242	state = st_ok;
2243	}
2244	}
2245	else	2228	else
2246	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	}
2247		2238
2248	break;	2239	break;
2249		2240
2250	case st_oct1:	2241	case st_oct1:
2251	case st_oct2:	2242	case st_oct2:
…		…
2255	backchar (SCHEME_A_ c);	2246	backchar (SCHEME_A_ c);
2256	state = st_ok;	2247	state = st_ok;
2257	}	2248	}
2258	else	2249	else
2259	{	2250	{
2260	if (state == st_oct2 && c1 >= 32)	2251	if (state == st_oct2 && c1 >= ' ')
2261	return S_F;	2252	return S_F;
2262		2253
2263	c1 = (c1 << 3) + (c - '0');	2254	c1 = (c1 << 3) + (c - '0');
2264		2255
2265	if (state == st_oct1)	2256	if (state == st_oct1)
…		…
2270	state = st_ok;	2261	state = st_ok;
2271	}	2262	}
2272	}	2263	}
2273		2264
2274	break;	2265	break;
2275
2276	}	2266	}
2277	}	2267	}
2278	}	2268	}
2279		2269
2280	/* check c is in chars */	2270	/* check c is in chars */
2281	static INLINE int	2271	ecb_cold int
2282	is_one_of (char *s, int c)	2272	is_one_of (const char *s, int c)
2283	{	2273	{
2284	if (c == EOF)
2285	return 1;
2286
2287	return !!strchr (s, c);	2274	return c == EOF || !!strchr (s, c);
2288	}	2275	}
2289		2276
2290	/* skip white characters */	2277	/* skip white characters */
2291	static INLINE int	2278	ecb_cold int
2292	skipspace (SCHEME_P)	2279	skipspace (SCHEME_P)
2293	{	2280	{
2294	int c, curr_line = 0;	2281	int c, curr_line = 0;
2295		2282
2296	do	2283	do
2297	{	2284	{
2298	c = inchar (SCHEME_A);	2285	c = inchar (SCHEME_A);
		2286
2299	#if SHOW_ERROR_LINE	2287	#if SHOW_ERROR_LINE
2300	if (c == '\n')	2288	if (ecb_expect_false (c == '\n'))
2301	curr_line++;	2289	curr_line++;
2302	#endif	2290	#endif
		2291
		2292	if (ecb_expect_false (c == EOF))
		2293	return c;
2303	}	2294	}
2304	while (c == ' ' || c == '\n' || c == '\r' || c == '\t');	2295	while (is_one_of (WHITESPACE, c));
2305		2296
2306	/* record it */	2297	/* record it */
2307	#if SHOW_ERROR_LINE	2298	#if SHOW_ERROR_LINE
2308	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)
2309	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;
2310	#endif	2301	#endif
2311		2302
2312	if (c != EOF)
2313	{
2314	backchar (SCHEME_A_ c);	2303	backchar (SCHEME_A_ c);
2315	return 1;	2304	return 1;
2316	}
2317	else
2318	return EOF;
2319	}	2305	}
2320		2306
2321	/* get token */	2307	/* get token */
2322	static int	2308	ecb_cold static int
2323	token (SCHEME_P)	2309	token (SCHEME_P)
2324	{	2310	{
2325	int c = skipspace (SCHEME_A);	2311	int c = skipspace (SCHEME_A);
2326		2312
2327	if (c == EOF)	2313	if (c == EOF)
…		…
2339	return TOK_RPAREN;	2325	return TOK_RPAREN;
2340		2326
2341	case '.':	2327	case '.':
2342	c = inchar (SCHEME_A);	2328	c = inchar (SCHEME_A);
2343		2329
2344	if (is_one_of (" \n\t", c))	2330	if (is_one_of (WHITESPACE, c))
2345	return TOK_DOT;	2331	return TOK_DOT;
2346	else	2332	else
2347	{	2333	{
2348	//TODO: ungetc twice in a row is not supported in C
2349	backchar (SCHEME_A_ c);	2334	backchar (SCHEME_A_ c);
2350	backchar (SCHEME_A_ '.');
2351	return TOK_ATOM;	2335	return TOK_DOTATOM;
2352	}	2336	}
		2337
		2338	case '|':
		2339	return TOK_STRATOM;
2353		2340
2354	case '\'':	2341	case '\'':
2355	return TOK_QUOTE;	2342	return TOK_QUOTE;
2356		2343
2357	case ';':	2344	case ';':
…		…
2424	}	2411	}
2425		2412
2426	/* ========== Routines for Printing ========== */	2413	/* ========== Routines for Printing ========== */
2427	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)	2414	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2428		2415
2429	static void	2416	ecb_cold static void
2430	printslashstring (SCHEME_P_ char *p, int len)	2417	printslashstring (SCHEME_P_ char *p, int len)
2431	{	2418	{
2432	int i;	2419	int i;
2433	unsigned char *s = (unsigned char *) p;	2420	unsigned char *s = (unsigned char *) p;
2434		2421
…		…
2489	}	2476	}
2490		2477
2491	putcharacter (SCHEME_A_ '"');	2478	putcharacter (SCHEME_A_ '"');
2492	}	2479	}
2493		2480
2494
2495	/* print atoms */	2481	/* print atoms */
2496	static void	2482	ecb_cold static void
2497	printatom (SCHEME_P_ pointer l, int f)	2483	printatom (SCHEME_P_ pointer l, int f)
2498	{	2484	{
2499	char *p;	2485	char *p;
2500	int len;	2486	int len;
2501		2487
2502	atom2str (SCHEME_A_ l, f, &p, &len);	2488	atom2str (SCHEME_A_ l, f, &p, &len);
2503	putchars (SCHEME_A_ p, len);	2489	putchars (SCHEME_A_ p, len);
2504	}	2490	}
2505		2491
2506
2507	/* Uses internal buffer unless string pointer is already available */	2492	/* Uses internal buffer unless string pointer is already available */
2508	static void	2493	ecb_cold static void
2509	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)	2494	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2510	{	2495	{
2511	char *p;	2496	char *p;
2512		2497
2513	if (l == NIL)	2498	if (l == NIL)
…		…
2524	{	2509	{
2525	p = SCHEME_V->strbuff;	2510	p = SCHEME_V->strbuff;
2526		2511
2527	if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */	2512	if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2528	{	2513	{
2529	if (num_is_integer (l))	2514	if (is_integer (l))
2530	xnum (p, ivalue_unchecked (l));	2515	xnum (p, ivalue_unchecked (l));
2531	#if USE_REAL	2516	#if USE_REAL
2532	else	2517	else
2533	{	2518	{
2534	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));	2519	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
…		…
2671	#endif	2656	#endif
2672	}	2657	}
2673	else if (is_continuation (l))	2658	else if (is_continuation (l))
2674	p = "#<CONTINUATION>";	2659	p = "#<CONTINUATION>";
2675	else	2660	else
		2661	{
		2662	#if USE_PRINTF
		2663	p = SCHEME_V->strbuff;
		2664	snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
		2665	#else
2676	p = "#<ERROR>";	2666	p = "#<ERROR>";
		2667	#endif
		2668	}
2677		2669
2678	*pp = p;	2670	*pp = p;
2679	*plen = strlen (p);	2671	*plen = strlen (p);
2680	}	2672	}
2681		2673
…		…
2713	return car (d);	2705	return car (d);
2714		2706
2715	p = cons (car (d), cdr (d));	2707	p = cons (car (d), cdr (d));
2716	q = p;	2708	q = p;
2717		2709
2718	while (cdr (cdr (p)) != NIL)	2710	while (cddr (p) != NIL)
2719	{	2711	{
2720	d = cons (car (p), cdr (p));	2712	d = cons (car (p), cdr (p));
2721		2713
2722	if (cdr (cdr (p)) != NIL)	2714	if (cddr (p) != NIL)
2723	p = cdr (d);	2715	p = cdr (d);
2724	}	2716	}
2725		2717
2726	set_cdr (p, car (cdr (p)));	2718	set_cdr (p, cadr (p));
2727	return q;	2719	return q;
2728	}	2720	}
2729		2721
2730	/* reverse list -- produce new list */	2722	/* reverse list -- produce new list */
2731	static pointer	2723	ecb_hot static pointer
2732	reverse (SCHEME_P_ pointer a)	2724	reverse (SCHEME_P_ pointer a)
2733	{	2725	{
2734	/* a must be checked by gc */	2726	/* a must be checked by gc */
2735	pointer p = NIL;	2727	pointer p = NIL;
2736		2728
…		…
2739		2731
2740	return p;	2732	return p;
2741	}	2733	}
2742		2734
2743	/* reverse list --- in-place */	2735	/* reverse list --- in-place */
2744	static pointer	2736	ecb_hot static pointer
2745	reverse_in_place (SCHEME_P_ pointer term, pointer list)	2737	reverse_in_place (SCHEME_P_ pointer term, pointer list)
2746	{	2738	{
2747	pointer result = term;	2739	pointer result = term;
2748	pointer p = list;	2740	pointer p = list;
2749		2741
…		…
2757		2749
2758	return result;	2750	return result;
2759	}	2751	}
2760		2752
2761	/* append list -- produce new list (in reverse order) */	2753	/* append list -- produce new list (in reverse order) */
2762	static pointer	2754	ecb_hot static pointer
2763	revappend (SCHEME_P_ pointer a, pointer b)	2755	revappend (SCHEME_P_ pointer a, pointer b)
2764	{	2756	{
2765	pointer result = a;	2757	pointer result = a;
2766	pointer p = b;	2758	pointer p = b;
2767		2759
…		…
2776		2768
2777	return S_F; /* signal an error */	2769	return S_F; /* signal an error */
2778	}	2770	}
2779		2771
2780	/* equivalence of atoms */	2772	/* equivalence of atoms */
2781	int	2773	ecb_hot int
2782	eqv (pointer a, pointer b)	2774	eqv (pointer a, pointer b)
2783	{	2775	{
2784	if (is_string (a))	2776	if (is_string (a))
2785	{	2777	{
2786	if (is_string (b))	2778	if (is_string (b))
…		…
2789	return 0;	2781	return 0;
2790	}	2782	}
2791	else if (is_number (a))	2783	else if (is_number (a))
2792	{	2784	{
2793	if (is_number (b))	2785	if (is_number (b))
2794	if (num_is_integer (a) == num_is_integer (b))
2795	return num_eq (nvalue (a), nvalue (b));	2786	return num_cmp (nvalue (a), nvalue (b)) == 0;
2796		2787
2797	return 0;	2788	return 0;
2798	}	2789	}
2799	else if (is_character (a))	2790	else if (is_character (a))
2800	{	2791	{
…		…
2826	/* () is #t in R5RS */	2817	/* () is #t in R5RS */
2827	#define is_true(p) ((p) != S_F)	2818	#define is_true(p) ((p) != S_F)
2828	#define is_false(p) ((p) == S_F)	2819	#define is_false(p) ((p) == S_F)
2829		2820
2830	/* ========== Environment implementation ========== */	2821	/* ========== Environment implementation ========== */
2831
2832	#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2833
2834	static int
2835	hash_fn (const char *key, int table_size)
2836	{
2837	const unsigned char *p = key;
2838	uint32_t hash = 2166136261;
2839
2840	while (*p)
2841	hash = (hash ^ *p++) * 16777619;
2842
2843	return hash % table_size;
2844	}
2845	#endif
2846		2822
2847	#ifndef USE_ALIST_ENV	2823	#ifndef USE_ALIST_ENV
2848		2824
2849	/*	2825	/*
2850	* In this implementation, each frame of the environment may be	2826	* In this implementation, each frame of the environment may be
…		…
2867		2843
2868	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2844	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2869	setenvironment (SCHEME_V->envir);	2845	setenvironment (SCHEME_V->envir);
2870	}	2846	}
2871		2847
2872	static INLINE void	2848	static uint32_t
		2849	sym_hash (pointer sym, uint32_t size)
		2850	{
		2851	uintptr_t ptr = (uintptr_t)sym;
		2852
		2853	#if 0
		2854	/* table size is prime, so why mix */
		2855	ptr += ptr >> 32;
		2856	ptr += ptr >> 16;
		2857	ptr += ptr >> 8;
		2858	#endif
		2859
		2860	return ptr % size;
		2861	}
		2862
		2863	ecb_inline void
2873	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2864	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2874	{	2865	{
2875	pointer slot = immutable_cons (variable, value);	2866	pointer slot = immutable_cons (variable, value);
2876		2867
2877	if (is_vector (car (env)))	2868	if (is_vector (car (env)))
2878	{	2869	{
2879	int location = hash_fn (symname (variable), veclength (car (env)));	2870	int location = sym_hash (variable, veclength (car (env)));
2880
2881	set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));	2871	vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2882	}	2872	}
2883	else	2873	else
2884	set_car (env, immutable_cons (slot, car (env)));	2874	set_car (env, immutable_cons (slot, car (env)));
2885	}	2875	}
2886		2876
2887	static pointer	2877	ecb_hot static pointer
2888	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)
2889	{	2879	{
2890	pointer x, y;	2880	pointer x, y;
2891	int location;
2892		2881
2893	for (x = env; x != NIL; x = cdr (x))	2882	for (x = env; x != NIL; x = cdr (x))
2894	{	2883	{
2895	if (is_vector (car (x)))	2884	if (is_vector (car (x)))
2896	{	2885	{
2897	location = hash_fn (symname (hdl), veclength (car (x)));	2886	int location = sym_hash (hdl, veclength (car (x)));
2898	y = vector_elem (car (x), location);	2887	y = vector_get (car (x), location);
2899	}	2888	}
2900	else	2889	else
2901	y = car (x);	2890	y = car (x);
2902		2891
2903	for (; y != NIL; y = cdr (y))	2892	for (; y != NIL; y = cdr (y))
2904	if (caar (y) == hdl)	2893	if (caar (y) == hdl)
2905	break;	2894	break;
2906		2895
2907	if (y != NIL)	2896	if (y != NIL)
		2897	return car (y);
		2898
		2899	if (!all)
2908	break;	2900	break;
2909
2910	if (!all)
2911	return NIL;
2912	}	2901	}
2913
2914	if (x != NIL)
2915	return car (y);
2916		2902
2917	return NIL;	2903	return NIL;
2918	}	2904	}
2919		2905
2920	#else /* USE_ALIST_ENV */	2906	#else /* USE_ALIST_ENV */
2921		2907
2922	static INLINE void	2908	static void
2923	new_frame_in_env (SCHEME_P_ pointer old_env)	2909	new_frame_in_env (SCHEME_P_ pointer old_env)
2924	{	2910	{
2925	SCHEME_V->envir = immutable_cons (NIL, old_env);	2911	SCHEME_V->envir = immutable_cons (NIL, old_env);
2926	setenvironment (SCHEME_V->envir);	2912	setenvironment (SCHEME_V->envir);
2927	}	2913	}
2928		2914
2929	static INLINE void	2915	static void
2930	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)
2931	{	2917	{
2932	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2918	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2933	}	2919	}
2934		2920
2935	static pointer	2921	ecb_hot static pointer
2936	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)
2937	{	2923	{
2938	pointer x, y;	2924	pointer x, y;
2939		2925
2940	for (x = env; x != NIL; x = cdr (x))	2926	for (x = env; x != NIL; x = cdr (x))
…		…
2942	for (y = car (x); y != NIL; y = cdr (y))	2928	for (y = car (x); y != NIL; y = cdr (y))
2943	if (caar (y) == hdl)	2929	if (caar (y) == hdl)
2944	break;	2930	break;
2945		2931
2946	if (y != NIL)	2932	if (y != NIL)
		2933	return car (y);
2947	break;	2934	break;
2948		2935
2949	if (!all)	2936	if (!all)
2950	return NIL;	2937	break;
2951	}	2938	}
2952
2953	if (x != NIL)
2954	return car (y);
2955		2939
2956	return NIL;	2940	return NIL;
2957	}	2941	}
2958		2942
2959	#endif /* USE_ALIST_ENV else */	2943	#endif /* USE_ALIST_ENV else */
2960		2944
2961	static INLINE void	2945	static void
2962	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2946	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2963	{	2947	{
		2948	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2964	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);
2965	}	2950	}
2966		2951
2967	static INLINE void	2952	static void
2968	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2953	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2969	{	2954	{
2970	set_cdr (slot, value);	2955	set_cdr (slot, value);
2971	}	2956	}
2972		2957
2973	static INLINE pointer	2958	static pointer
2974	slot_value_in_env (pointer slot)	2959	slot_value_in_env (pointer slot)
2975	{	2960	{
2976	return cdr (slot);	2961	return cdr (slot);
2977	}	2962	}
2978		2963
2979	/* ========== Evaluation Cycle ========== */	2964	/* ========== Evaluation Cycle ========== */
2980		2965
2981	static pointer	2966	ecb_cold static int
2982	xError_1 (SCHEME_P_ const char *s, pointer a)	2967	xError_1 (SCHEME_P_ const char *s, pointer a)
2983	{	2968	{
2984	#if USE_ERROR_HOOK	2969	#if USE_ERROR_HOOK
2985	pointer x;	2970	pointer x;
2986	pointer hdl = SCHEME_V->ERROR_HOOK;	2971	pointer hdl = SCHEME_V->ERROR_HOOK;
…		…
3021	code = cons (mk_string (SCHEME_A_ s), code);	3006	code = cons (mk_string (SCHEME_A_ s), code);
3022	setimmutable (car (code));	3007	setimmutable (car (code));
3023	SCHEME_V->code = cons (slot_value_in_env (x), code);	3008	SCHEME_V->code = cons (slot_value_in_env (x), code);
3024	SCHEME_V->op = OP_EVAL;	3009	SCHEME_V->op = OP_EVAL;
3025		3010
3026	return S_T;	3011	return 0;
3027	}	3012	}
3028	#endif	3013	#endif
3029		3014
3030	if (a)	3015	if (a)
3031	SCHEME_V->args = cons (a, NIL);	3016	SCHEME_V->args = cons (a, NIL);
…		…
3033	SCHEME_V->args = NIL;	3018	SCHEME_V->args = NIL;
3034		3019
3035	SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);	3020	SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
3036	setimmutable (car (SCHEME_V->args));	3021	setimmutable (car (SCHEME_V->args));
3037	SCHEME_V->op = OP_ERR0;	3022	SCHEME_V->op = OP_ERR0;
		3023
3038	return S_T;	3024	return 0;
3039	}	3025	}
3040		3026
3041	#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)	3027	#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
3042	#define Error_0(s) Error_1 (s, 0)	3028	#define Error_0(s) Error_1 (s, 0)
3043		3029
3044	/* Too small to turn into function */	3030	/* Too small to turn into function */
3045	#define BEGIN do {	3031	#define BEGIN do {
3046	#define END } while (0)	3032	#define END } while (0)
3047	#define s_goto(a) BEGIN \	3033	#define s_goto(a) BEGIN \
3048	SCHEME_V->op = a; \	3034	SCHEME_V->op = a; \
3049	return S_T; END	3035	return 0; END
3050		3036
3051	#define s_return(a) return xs_return (SCHEME_A_ a)	3037	#define s_return(a) return xs_return (SCHEME_A_ a)
3052		3038
3053	#ifndef USE_SCHEME_STACK	3039	#ifndef USE_SCHEME_STACK
3054		3040
…		…
3061	pointer code;	3047	pointer code;
3062	};	3048	};
3063		3049
3064	# define STACK_GROWTH 3	3050	# define STACK_GROWTH 3
3065		3051
3066	static void	3052	ecb_hot static void
3067	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)
3068	{	3054	{
3069	int nframes = (uintptr_t)SCHEME_V->dump;	3055	int nframes = (uintptr_t)SCHEME_V->dump;
3070	struct dump_stack_frame *next_frame;	3056	struct dump_stack_frame *next_frame;
3071		3057
3072	/* enough room for the next frame? */	3058	/* enough room for the next frame? */
3073	if (nframes >= SCHEME_V->dump_size)	3059	if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3074	{	3060	{
3075	SCHEME_V->dump_size += STACK_GROWTH;	3061	SCHEME_V->dump_size += STACK_GROWTH;
3076	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);
3077	}	3063	}
3078		3064
3079	next_frame = SCHEME_V->dump_base + nframes;	3065	next_frame = SCHEME_V->dump_base + nframes;
3080		3066
3081	next_frame->op = op;	3067	next_frame->op = op;
3082	next_frame->args = args;	3068	next_frame->args = args;
3083	next_frame->envir = SCHEME_V->envir;	3069	next_frame->envir = SCHEME_V->envir;
3084	next_frame->code = code;	3070	next_frame->code = code;
3085		3071
3086	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3072	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3087	}	3073	}
3088		3074
3089	static pointer	3075	static ecb_hot int
3090	xs_return (SCHEME_P_ pointer a)	3076	xs_return (SCHEME_P_ pointer a)
3091	{	3077	{
3092	int nframes = (uintptr_t)SCHEME_V->dump;	3078	int nframes = (uintptr_t)SCHEME_V->dump;
3093	struct dump_stack_frame *frame;	3079	struct dump_stack_frame *frame;
3094		3080
3095	SCHEME_V->value = a;	3081	SCHEME_V->value = a;
3096		3082
3097	if (nframes <= 0)	3083	if (nframes <= 0)
3098	return NIL;	3084	return -1;
3099		3085
3100	frame = &SCHEME_V->dump_base[--nframes];	3086	frame = &SCHEME_V->dump_base[--nframes];
3101	SCHEME_V->op = frame->op;	3087	SCHEME_V->op = frame->op;
3102	SCHEME_V->args = frame->args;	3088	SCHEME_V->args = frame->args;
3103	SCHEME_V->envir = frame->envir;	3089	SCHEME_V->envir = frame->envir;
3104	SCHEME_V->code = frame->code;	3090	SCHEME_V->code = frame->code;
3105	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3091	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3106		3092
3107	return S_T;	3093	return 0;
3108	}	3094	}
3109		3095
3110	static INLINE void	3096	ecb_cold void
3111	dump_stack_reset (SCHEME_P)	3097	dump_stack_reset (SCHEME_P)
3112	{	3098	{
3113	/* 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 */
3114	SCHEME_V->dump = (pointer)+0;	3100	SCHEME_V->dump = (pointer)+0;
3115	}	3101	}
3116		3102
3117	static INLINE void	3103	ecb_cold void
3118	dump_stack_initialize (SCHEME_P)	3104	dump_stack_initialize (SCHEME_P)
3119	{	3105	{
3120	SCHEME_V->dump_size = 0;	3106	SCHEME_V->dump_size = 0;
3121	SCHEME_V->dump_base = 0;	3107	SCHEME_V->dump_base = 0;
3122	dump_stack_reset (SCHEME_A);	3108	dump_stack_reset (SCHEME_A);
3123	}	3109	}
3124		3110
3125	static void	3111	ecb_cold static void
3126	dump_stack_free (SCHEME_P)	3112	dump_stack_free (SCHEME_P)
3127	{	3113	{
3128	free (SCHEME_V->dump_base);	3114	free (SCHEME_V->dump_base);
3129	SCHEME_V->dump_base = 0;	3115	SCHEME_V->dump_base = 0;
3130	SCHEME_V->dump = (pointer)0;	3116	SCHEME_V->dump = (pointer)0;
3131	SCHEME_V->dump_size = 0;	3117	SCHEME_V->dump_size = 0;
3132	}	3118	}
3133		3119
3134	static void	3120	ecb_cold static void
3135	dump_stack_mark (SCHEME_P)	3121	dump_stack_mark (SCHEME_P)
3136	{	3122	{
3137	int nframes = (uintptr_t)SCHEME_V->dump;	3123	int nframes = (uintptr_t)SCHEME_V->dump;
3138	int i;	3124	int i;
3139		3125
…		…
3145	mark (frame->envir);	3131	mark (frame->envir);
3146	mark (frame->code);	3132	mark (frame->code);
3147	}	3133	}
3148	}	3134	}
3149		3135
3150	static pointer	3136	ecb_cold static pointer
3151	ss_get_cont (SCHEME_P)	3137	ss_get_cont (SCHEME_P)
3152	{	3138	{
3153	int nframes = (uintptr_t)SCHEME_V->dump;	3139	int nframes = (uintptr_t)SCHEME_V->dump;
3154	int i;	3140	int i;
3155		3141
…		…
3167	}	3153	}
3168		3154
3169	return cont;	3155	return cont;
3170	}	3156	}
3171		3157
3172	static void	3158	ecb_cold static void
3173	ss_set_cont (SCHEME_P_ pointer cont)	3159	ss_set_cont (SCHEME_P_ pointer cont)
3174	{	3160	{
3175	int i = 0;	3161	int i = 0;
3176	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3162	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3177		3163
3178	while (cont != NIL)	3164	while (cont != NIL)
3179	{	3165	{
3180	frame->op = ivalue (car (cont)); cont = cdr (cont);	3166	frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont);
3181	frame->args = car (cont) ; cont = cdr (cont);	3167	frame->args = car (cont) ; cont = cdr (cont);
3182	frame->envir = car (cont) ; cont = cdr (cont);	3168	frame->envir = car (cont) ; cont = cdr (cont);
3183	frame->code = car (cont) ; cont = cdr (cont);	3169	frame->code = car (cont) ; cont = cdr (cont);
3184		3170
3185	++frame;	3171	++frame;
3186	++i;	3172	++i;
3187	}	3173	}
3188		3174
3189	SCHEME_V->dump = (pointer)(uintptr_t)i;	3175	SCHEME_V->dump = (pointer)(uintptr_t)i;
3190	}	3176	}
3191		3177
3192	#else	3178	#else
3193		3179
3194	static INLINE void	3180	ecb_cold void
3195	dump_stack_reset (SCHEME_P)	3181	dump_stack_reset (SCHEME_P)
3196	{	3182	{
3197	SCHEME_V->dump = NIL;	3183	SCHEME_V->dump = NIL;
3198	}	3184	}
3199		3185
3200	static INLINE void	3186	ecb_cold void
3201	dump_stack_initialize (SCHEME_P)	3187	dump_stack_initialize (SCHEME_P)
3202	{	3188	{
3203	dump_stack_reset (SCHEME_A);	3189	dump_stack_reset (SCHEME_A);
3204	}	3190	}
3205		3191
3206	static void	3192	ecb_cold static void
3207	dump_stack_free (SCHEME_P)	3193	dump_stack_free (SCHEME_P)
3208	{	3194	{
3209	SCHEME_V->dump = NIL;	3195	SCHEME_V->dump = NIL;
3210	}	3196	}
3211		3197
3212	static pointer	3198	ecb_hot static int
3213	xs_return (SCHEME_P_ pointer a)	3199	xs_return (SCHEME_P_ pointer a)
3214	{	3200	{
3215	pointer dump = SCHEME_V->dump;	3201	pointer dump = SCHEME_V->dump;
3216		3202
3217	SCHEME_V->value = a;	3203	SCHEME_V->value = a;
3218		3204
3219	if (dump == NIL)	3205	if (dump == NIL)
3220	return NIL;	3206	return -1;
3221		3207
3222	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);	3208	SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump);
3223	SCHEME_V->args = car (dump) ; dump = cdr (dump);	3209	SCHEME_V->args = car (dump) ; dump = cdr (dump);
3224	SCHEME_V->envir = car (dump) ; dump = cdr (dump);	3210	SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3225	SCHEME_V->code = car (dump) ; dump = cdr (dump);	3211	SCHEME_V->code = car (dump) ; dump = cdr (dump);
3226		3212
3227	SCHEME_V->dump = dump;	3213	SCHEME_V->dump = dump;
3228		3214
3229	return S_T;	3215	return 0;
3230	}	3216	}
3231		3217
3232	static void	3218	ecb_hot static void
3233	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)
3234	{	3220	{
3235	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),	3221	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3236	cons (args,	3222	cons (args,
3237	cons (SCHEME_V->envir,	3223	cons (SCHEME_V->envir,
3238	cons (code,	3224	cons (code,
3239	SCHEME_V->dump))));	3225	SCHEME_V->dump))));
3240	}	3226	}
3241		3227
3242	static void	3228	ecb_cold static void
3243	dump_stack_mark (SCHEME_P)	3229	dump_stack_mark (SCHEME_P)
3244	{	3230	{
3245	mark (SCHEME_V->dump);	3231	mark (SCHEME_V->dump);
3246	}	3232	}
3247		3233
3248	static pointer	3234	ecb_cold static pointer
3249	ss_get_cont (SCHEME_P)	3235	ss_get_cont (SCHEME_P)
3250	{	3236	{
3251	return SCHEME_V->dump;	3237	return SCHEME_V->dump;
3252	}	3238	}
3253		3239
3254	static void	3240	ecb_cold static void
3255	ss_set_cont (SCHEME_P_ pointer cont)	3241	ss_set_cont (SCHEME_P_ pointer cont)
3256	{	3242	{
3257	SCHEME_V->dump = cont;	3243	SCHEME_V->dump = cont;
3258	}	3244	}
3259		3245
3260	#endif	3246	#endif
3261		3247
3262	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3248	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3263		3249
		3250	#if EXPERIMENT
3264	static pointer	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
3265	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3310	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3266	{	3311	{
		3312	pointer args = SCHEME_V->args;
3267	pointer x, y;	3313	pointer x, y;
3268		3314
3269	switch (op)	3315	switch (op)
3270	{	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
3271	case OP_LOAD: /* load */	3323	case OP_LOAD: /* load */
3272	if (file_interactive (SCHEME_A))	3324	if (file_interactive (SCHEME_A))
3273	{	3325	{
3274	xwrstr ("Loading "); xwrstr (strvalue (car (SCHEME_V->args))); xwrstr ("\n");	3326	putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
3275	//D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (SCHEME_V->args)));	3327	//D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3276	}	3328	}
3277		3329
3278	if (!file_push (SCHEME_A_ strvalue (car (SCHEME_V->args))))	3330	if (!file_push (SCHEME_A_ strvalue (car (args))))
3279	Error_1 ("unable to open", car (SCHEME_V->args));	3331	Error_1 ("unable to open", car (args));
3280	else	3332	else
3281	{	3333	{
3282	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	3334	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3283	s_goto (OP_T0LVL);	3335	s_goto (OP_T0LVL);
3284	}	3336	}
3285		3337
3286	case OP_T0LVL: /* top level */	3338	case OP_T0LVL: /* top level */
3287		3339
3288	/* If we reached the end of file, this loop is done. */	3340	/* If we reached the end of file, this loop is done. */
3289	if (SCHEME_V->loadport->object.port->kind & port_saw_EOF)	3341	if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3290	{	3342	{
3291	if (SCHEME_V->file_i == 0)	3343	if (SCHEME_V->file_i == 0)
3292	{	3344	{
3293	SCHEME_V->args = NIL;	3345	SCHEME_V->args = NIL;
3294	s_goto (OP_QUIT);	3346	s_goto (OP_QUIT);
…		…
3358	case OP_EVAL: /* main part of evaluation */	3410	case OP_EVAL: /* main part of evaluation */
3359	#if USE_TRACING	3411	#if USE_TRACING
3360	if (SCHEME_V->tracing)	3412	if (SCHEME_V->tracing)
3361	{	3413	{
3362	/*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */	3414	/*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */
3363	s_save (SCHEME_A_ OP_REAL_EVAL, SCHEME_V->args, SCHEME_V->code);	3415	s_save (SCHEME_A_ OP_REAL_EVAL, args, SCHEME_V->code);
3364	SCHEME_V->args = SCHEME_V->code;	3416	SCHEME_V->args = SCHEME_V->code;
3365	putstr (SCHEME_A_ "\nEval: ");	3417	putstr (SCHEME_A_ "\nEval: ");
3366	s_goto (OP_P0LIST);	3418	s_goto (OP_P0LIST);
3367	}	3419	}
3368		3420
…		…
3372	#endif	3424	#endif
3373	if (is_symbol (SCHEME_V->code)) /* symbol */	3425	if (is_symbol (SCHEME_V->code)) /* symbol */
3374	{	3426	{
3375	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);
3376		3428
3377	if (x != NIL)	3429	if (x == NIL)
3378	s_return (slot_value_in_env (x));
3379	else
3380	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));
3381	}	3433	}
3382	else if (is_pair (SCHEME_V->code))	3434	else if (is_pair (SCHEME_V->code))
3383	{	3435	{
3384	x = car (SCHEME_V->code);	3436	x = car (SCHEME_V->code);
3385		3437
…		…
3398	}	3450	}
3399	else	3451	else
3400	s_return (SCHEME_V->code);	3452	s_return (SCHEME_V->code);
3401		3453
3402	case OP_E0ARGS: /* eval arguments */	3454	case OP_E0ARGS: /* eval arguments */
3403	if (is_macro (SCHEME_V->value)) /* macro expansion */	3455	if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3404	{	3456	{
3405	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);	3457	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3406	SCHEME_V->args = cons (SCHEME_V->code, NIL);	3458	SCHEME_V->args = cons (SCHEME_V->code, NIL);
3407	SCHEME_V->code = SCHEME_V->value;	3459	SCHEME_V->code = SCHEME_V->value;
3408	s_goto (OP_APPLY);	3460	s_goto (OP_APPLY);
…		…
3412	SCHEME_V->code = cdr (SCHEME_V->code);	3464	SCHEME_V->code = cdr (SCHEME_V->code);
3413	s_goto (OP_E1ARGS);	3465	s_goto (OP_E1ARGS);
3414	}	3466	}
3415		3467
3416	case OP_E1ARGS: /* eval arguments */	3468	case OP_E1ARGS: /* eval arguments */
3417	SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args);	3469	args = cons (SCHEME_V->value, args);
3418		3470
3419	if (is_pair (SCHEME_V->code)) /* continue */	3471	if (is_pair (SCHEME_V->code)) /* continue */
3420	{	3472	{
3421	s_save (SCHEME_A_ OP_E1ARGS, SCHEME_V->args, cdr (SCHEME_V->code));	3473	s_save (SCHEME_A_ OP_E1ARGS, args, cdr (SCHEME_V->code));
3422	SCHEME_V->code = car (SCHEME_V->code);	3474	SCHEME_V->code = car (SCHEME_V->code);
3423	SCHEME_V->args = NIL;	3475	SCHEME_V->args = NIL;
3424	s_goto (OP_EVAL);	3476	s_goto (OP_EVAL);
3425	}	3477	}
3426	else /* end */	3478	else /* end */
3427	{	3479	{
3428	SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args);	3480	args = reverse_in_place (SCHEME_A_ NIL, args);
3429	SCHEME_V->code = car (SCHEME_V->args);	3481	SCHEME_V->code = car (args);
3430	SCHEME_V->args = cdr (SCHEME_V->args);	3482	SCHEME_V->args = cdr (args);
3431	s_goto (OP_APPLY);	3483	s_goto (OP_APPLY);
3432	}	3484	}
3433		3485
3434	#if USE_TRACING	3486	#if USE_TRACING
3435		3487
3436	case OP_TRACING:	3488	case OP_TRACING:
3437	{	3489	{
3438	int tr = SCHEME_V->tracing;	3490	int tr = SCHEME_V->tracing;
3439		3491
3440	SCHEME_V->tracing = ivalue (car (SCHEME_V->args));	3492	SCHEME_V->tracing = ivalue_unchecked (car (args));
3441	s_return (mk_integer (SCHEME_A_ tr));	3493	s_return (mk_integer (SCHEME_A_ tr));
3442	}	3494	}
3443		3495
3444	#endif	3496	#endif
3445		3497
3446	case OP_APPLY: /* apply 'code' to 'args' */	3498	case OP_APPLY: /* apply 'code' to 'args' */
3447	#if USE_TRACING	3499	#if USE_TRACING
3448	if (SCHEME_V->tracing)	3500	if (SCHEME_V->tracing)
3449	{	3501	{
3450	s_save (SCHEME_A_ OP_REAL_APPLY, SCHEME_V->args, SCHEME_V->code);	3502	s_save (SCHEME_A_ OP_REAL_APPLY, args, SCHEME_V->code);
3451	SCHEME_V->print_flag = 1;	3503	SCHEME_V->print_flag = 1;
3452	/* SCHEME_V->args=cons(SCHEME_V->code,SCHEME_V->args); */	3504	/* args=cons(SCHEME_V->code,args); */
3453	putstr (SCHEME_A_ "\nApply to: ");	3505	putstr (SCHEME_A_ "\nApply to: ");
3454	s_goto (OP_P0LIST);	3506	s_goto (OP_P0LIST);
3455	}	3507	}
3456		3508
3457	/* fall through */	3509	/* fall through */
3458		3510
3459	case OP_REAL_APPLY:	3511	case OP_REAL_APPLY:
3460	#endif	3512	#endif
3461	if (is_proc (SCHEME_V->code))	3513	if (is_proc (SCHEME_V->code))
3462	{
3463	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */	3514	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3464	}
3465	else if (is_foreign (SCHEME_V->code))	3515	else if (is_foreign (SCHEME_V->code))
3466	{	3516	{
3467	/* Keep nested calls from GC'ing the arglist */	3517	/* Keep nested calls from GC'ing the arglist */
3468	push_recent_alloc (SCHEME_A_ SCHEME_V->args, NIL);	3518	push_recent_alloc (SCHEME_A_ args, NIL);
3469	x = SCHEME_V->code->object.ff (SCHEME_A_ SCHEME_V->args);	3519	x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3470		3520
3471	s_return (x);	3521	s_return (x);
3472	}	3522	}
3473	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 */
3474	{	3524	{
3475	/* Should not accept promise */	3525	/* Should not accept promise */
3476	/* make environment */	3526	/* make environment */
3477	new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));	3527	new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));
3478		3528
3479	for (x = car (closure_code (SCHEME_V->code)), y = SCHEME_V->args; is_pair (x); x = cdr (x), y = cdr (y))	3529	for (x = car (closure_code (SCHEME_V->code)), y = args; is_pair (x); x = cdr (x), y = cdr (y))
3480	{	3530	{
3481	if (y == NIL)	3531	if (y == NIL)
3482	Error_0 ("not enough arguments");	3532	Error_0 ("not enough arguments");
3483	else	3533	else
3484	new_slot_in_env (SCHEME_A_ car (x), car (y));	3534	new_slot_in_env (SCHEME_A_ car (x), car (y));
…		…
3502	s_goto (OP_BEGIN);	3552	s_goto (OP_BEGIN);
3503	}	3553	}
3504	else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */	3554	else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3505	{	3555	{
3506	ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));	3556	ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3507	s_return (SCHEME_V->args != NIL ? car (SCHEME_V->args) : NIL);	3557	s_return (args != NIL ? car (args) : NIL);
3508	}	3558	}
3509	else	3559	else
3510	Error_0 ("illegal function");	3560	Error_0 ("illegal function");
3511		3561
3512	case OP_DOMACRO: /* do macro */	3562	case OP_DOMACRO: /* do macro */
3513	SCHEME_V->code = SCHEME_V->value;	3563	SCHEME_V->code = SCHEME_V->value;
3514	s_goto (OP_EVAL);	3564	s_goto (OP_EVAL);
3515
3516	#if 1
3517		3565
3518	case OP_LAMBDA: /* lambda */	3566	case OP_LAMBDA: /* lambda */
3519	/* 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
3520	set SCHEME_V->value fall thru */	3568	set SCHEME_V->value fall thru */
3521	{	3569	{
3522	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);
3523		3571
3524	if (f != NIL)	3572	if (f != NIL)
3525	{	3573	{
3526	s_save (SCHEME_A_ OP_LAMBDA1, SCHEME_V->args, SCHEME_V->code);	3574	s_save (SCHEME_A_ OP_LAMBDA1, args, SCHEME_V->code);
3527	SCHEME_V->args = cons (SCHEME_V->code, NIL);	3575	SCHEME_V->args = cons (SCHEME_V->code, NIL);
3528	SCHEME_V->code = slot_value_in_env (f);	3576	SCHEME_V->code = slot_value_in_env (f);
3529	s_goto (OP_APPLY);	3577	s_goto (OP_APPLY);
3530	}	3578	}
3531		3579
3532	SCHEME_V->value = SCHEME_V->code;	3580	SCHEME_V->value = SCHEME_V->code;
3533	/* Fallthru */
3534	}	3581	}
		3582	/* Fallthru */
3535		3583
3536	case OP_LAMBDA1:	3584	case OP_LAMBDA1:
3537	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));
3538		3586
3539	#else
3540
3541	case OP_LAMBDA: /* lambda */
3542	s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3543
3544	#endif
3545
3546	case OP_MKCLOSURE: /* make-closure */	3587	case OP_MKCLOSURE: /* make-closure */
3547	x = car (SCHEME_V->args);	3588	x = car (args);
3548		3589
3549	if (car (x) == SCHEME_V->LAMBDA)	3590	if (car (x) == SCHEME_V->LAMBDA)
3550	x = cdr (x);	3591	x = cdr (x);
3551		3592
3552	if (cdr (SCHEME_V->args) == NIL)	3593	if (cdr (args) == NIL)
3553	y = SCHEME_V->envir;	3594	y = SCHEME_V->envir;
3554	else	3595	else
3555	y = cadr (SCHEME_V->args);	3596	y = cadr (args);
3556		3597
3557	s_return (mk_closure (SCHEME_A_ x, y));	3598	s_return (mk_closure (SCHEME_A_ x, y));
3558		3599
3559	case OP_QUOTE: /* quote */	3600	case OP_QUOTE: /* quote */
3560	s_return (car (SCHEME_V->code));	3601	s_return (car (SCHEME_V->code));
…		…
3592		3633
3593		3634
3594	case OP_DEFP: /* defined? */	3635	case OP_DEFP: /* defined? */
3595	x = SCHEME_V->envir;	3636	x = SCHEME_V->envir;
3596		3637
3597	if (cdr (SCHEME_V->args) != NIL)	3638	if (cdr (args) != NIL)
3598	x = cadr (SCHEME_V->args);	3639	x = cadr (args);
3599		3640
3600	s_retbool (find_slot_in_env (SCHEME_A_ x, car (SCHEME_V->args), 1) != NIL);	3641	s_retbool (find_slot_in_env (SCHEME_A_ x, car (args), 1) != NIL);
3601		3642
3602	case OP_SET0: /* set! */	3643	case OP_SET0: /* set! */
3603	if (is_immutable (car (SCHEME_V->code)))	3644	if (is_immutable (car (SCHEME_V->code)))
3604	Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code));	3645	Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code));
3605		3646
…		…
3636		3677
3637	case OP_IF1: /* if */	3678	case OP_IF1: /* if */
3638	if (is_true (SCHEME_V->value))	3679	if (is_true (SCHEME_V->value))
3639	SCHEME_V->code = car (SCHEME_V->code);	3680	SCHEME_V->code = car (SCHEME_V->code);
3640	else	3681	else
3641	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because	3682	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3642
3643	* car(NIL) = NIL */
3644	s_goto (OP_EVAL);	3683	s_goto (OP_EVAL);
3645		3684
3646	case OP_LET0: /* let */	3685	case OP_LET0: /* let */
3647	SCHEME_V->args = NIL;	3686	SCHEME_V->args = NIL;
3648	SCHEME_V->value = SCHEME_V->code;	3687	SCHEME_V->value = SCHEME_V->code;
3649	SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);	3688	SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3650	s_goto (OP_LET1);	3689	s_goto (OP_LET1);
3651		3690
3652	case OP_LET1: /* let (calculate parameters) */	3691	case OP_LET1: /* let (calculate parameters) */
3653	SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args);	3692	args = cons (SCHEME_V->value, args);
3654		3693
3655	if (is_pair (SCHEME_V->code)) /* continue */	3694	if (is_pair (SCHEME_V->code)) /* continue */
3656	{	3695	{
3657	if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))	3696	if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3658	Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code));	3697	Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code));
3659		3698
3660	s_save (SCHEME_A_ OP_LET1, SCHEME_V->args, cdr (SCHEME_V->code));	3699	s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code));
3661	SCHEME_V->code = cadar (SCHEME_V->code);	3700	SCHEME_V->code = cadar (SCHEME_V->code);
3662	SCHEME_V->args = NIL;	3701	SCHEME_V->args = NIL;
3663	s_goto (OP_EVAL);	3702	s_goto (OP_EVAL);
3664	}	3703	}
3665	else /* end */	3704	else /* end */
3666	{	3705	{
3667	SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args);	3706	args = reverse_in_place (SCHEME_A_ NIL, args);
3668	SCHEME_V->code = car (SCHEME_V->args);	3707	SCHEME_V->code = car (args);
3669	SCHEME_V->args = cdr (SCHEME_V->args);	3708	SCHEME_V->args = cdr (args);
3670	s_goto (OP_LET2);	3709	s_goto (OP_LET2);
3671	}	3710	}
3672		3711
3673	case OP_LET2: /* let */	3712	case OP_LET2: /* let */
3674	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);	3713	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3675		3714
3676	for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = SCHEME_V->args;	3715	for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
3677	y != NIL; x = cdr (x), y = cdr (y))	3716	y != NIL; x = cdr (x), y = cdr (y))
3678	new_slot_in_env (SCHEME_A_ caar (x), car (y));	3717	new_slot_in_env (SCHEME_A_ caar (x), car (y));
3679		3718
3680	if (is_symbol (car (SCHEME_V->code))) /* named let */	3719	if (is_symbol (car (SCHEME_V->code))) /* named let */
3681	{	3720	{
3682	for (x = cadr (SCHEME_V->code), SCHEME_V->args = NIL; x != NIL; x = cdr (x))	3721	for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3683	{	3722	{
3684	if (!is_pair (x))	3723	if (!is_pair (x))
3685	Error_1 ("Bad syntax of binding in let :", x);	3724	Error_1 ("Bad syntax of binding in let :", x);
3686		3725
3687	if (!is_list (SCHEME_A_ car (x)))	3726	if (!is_list (SCHEME_A_ car (x)))
3688	Error_1 ("Bad syntax of binding in let :", car (x));	3727	Error_1 ("Bad syntax of binding in let :", car (x));
3689		3728
3690	SCHEME_V->args = cons (caar (x), SCHEME_V->args);	3729	args = cons (caar (x), args);
3691	}	3730	}
3692		3731
3693	x =
3694	mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args), cddr (SCHEME_V->code)),	3732	x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
3695	SCHEME_V->envir);	3733	SCHEME_V->envir);
3696	new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x);	3734	new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x);
3697	SCHEME_V->code = cddr (SCHEME_V->code);	3735	SCHEME_V->code = cddr (SCHEME_V->code);
3698	SCHEME_V->args = NIL;
3699	}	3736	}
3700	else	3737	else
3701	{	3738	{
3702	SCHEME_V->code = cdr (SCHEME_V->code);	3739	SCHEME_V->code = cdr (SCHEME_V->code);
		3740	}
		3741
3703	SCHEME_V->args = NIL;	3742	SCHEME_V->args = NIL;
3704	}
3705
3706	s_goto (OP_BEGIN);	3743	s_goto (OP_BEGIN);
3707		3744
3708	case OP_LET0AST: /* let* */	3745	case OP_LET0AST: /* let* */
3709	if (car (SCHEME_V->code) == NIL)	3746	if (car (SCHEME_V->code) == NIL)
3710	{	3747	{
…		…
3728	new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value);	3765	new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value);
3729	SCHEME_V->code = cdr (SCHEME_V->code);	3766	SCHEME_V->code = cdr (SCHEME_V->code);
3730		3767
3731	if (is_pair (SCHEME_V->code)) /* continue */	3768	if (is_pair (SCHEME_V->code)) /* continue */
3732	{	3769	{
3733	s_save (SCHEME_A_ OP_LET2AST, SCHEME_V->args, SCHEME_V->code);	3770	s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3734	SCHEME_V->code = cadar (SCHEME_V->code);	3771	SCHEME_V->code = cadar (SCHEME_V->code);
3735	SCHEME_V->args = NIL;	3772	SCHEME_V->args = NIL;
3736	s_goto (OP_EVAL);	3773	s_goto (OP_EVAL);
3737	}	3774	}
3738	else /* end */	3775	else /* end */
3739	{	3776	{
3740	SCHEME_V->code = SCHEME_V->args;	3777	SCHEME_V->code = args;
3741	SCHEME_V->args = NIL;	3778	SCHEME_V->args = NIL;
3742	s_goto (OP_BEGIN);	3779	s_goto (OP_BEGIN);
3743	}	3780	}
3744		3781
3745	case OP_LET0REC: /* letrec */	3782	case OP_LET0REC: /* letrec */
…		…
3748	SCHEME_V->value = SCHEME_V->code;	3785	SCHEME_V->value = SCHEME_V->code;
3749	SCHEME_V->code = car (SCHEME_V->code);	3786	SCHEME_V->code = car (SCHEME_V->code);
3750	s_goto (OP_LET1REC);	3787	s_goto (OP_LET1REC);
3751		3788
3752	case OP_LET1REC: /* letrec (calculate parameters) */	3789	case OP_LET1REC: /* letrec (calculate parameters) */
3753	SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args);	3790	args = cons (SCHEME_V->value, args);
3754		3791
3755	if (is_pair (SCHEME_V->code)) /* continue */	3792	if (is_pair (SCHEME_V->code)) /* continue */
3756	{	3793	{
3757	if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))	3794	if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3758	Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));	3795	Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3759		3796
3760	s_save (SCHEME_A_ OP_LET1REC, SCHEME_V->args, cdr (SCHEME_V->code));	3797	s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3761	SCHEME_V->code = cadar (SCHEME_V->code);	3798	SCHEME_V->code = cadar (SCHEME_V->code);
3762	SCHEME_V->args = NIL;	3799	SCHEME_V->args = NIL;
3763	s_goto (OP_EVAL);	3800	s_goto (OP_EVAL);
3764	}	3801	}
3765	else /* end */	3802	else /* end */
3766	{	3803	{
3767	SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args);	3804	args = reverse_in_place (SCHEME_A_ NIL, args);
3768	SCHEME_V->code = car (SCHEME_V->args);	3805	SCHEME_V->code = car (args);
3769	SCHEME_V->args = cdr (SCHEME_V->args);	3806	SCHEME_V->args = cdr (args);
3770	s_goto (OP_LET2REC);	3807	s_goto (OP_LET2REC);
3771	}	3808	}
3772		3809
3773	case OP_LET2REC: /* letrec */	3810	case OP_LET2REC: /* letrec */
3774	for (x = car (SCHEME_V->code), y = SCHEME_V->args; y != NIL; x = cdr (x), y = cdr (y))	3811	for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3775	new_slot_in_env (SCHEME_A_ caar (x), car (y));	3812	new_slot_in_env (SCHEME_A_ caar (x), car (y));
3776		3813
3777	SCHEME_V->code = cdr (SCHEME_V->code);	3814	SCHEME_V->code = cdr (SCHEME_V->code);
3778	SCHEME_V->args = NIL;	3815	SCHEME_V->args = NIL;
3779	s_goto (OP_BEGIN);	3816	s_goto (OP_BEGIN);
…		…
3865	s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));	3902	s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3866	SCHEME_V->code = car (SCHEME_V->code);	3903	SCHEME_V->code = car (SCHEME_V->code);
3867	s_goto (OP_EVAL);	3904	s_goto (OP_EVAL);
3868		3905
3869	case OP_C1STREAM: /* cons-stream */	3906	case OP_C1STREAM: /* cons-stream */
3870	SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register SCHEME_V->args for gc */	3907	SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register args for gc */
3871	x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);	3908	x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3872	set_typeflag (x, T_PROMISE);	3909	set_typeflag (x, T_PROMISE);
3873	s_return (cons (SCHEME_V->args, x));	3910	s_return (cons (args, x));
3874		3911
3875	case OP_MACRO0: /* macro */	3912	case OP_MACRO0: /* macro */
3876	if (is_pair (car (SCHEME_V->code)))	3913	if (is_pair (car (SCHEME_V->code)))
3877	{	3914	{
3878	x = caar (SCHEME_V->code);	3915	x = caar (SCHEME_V->code);
…		…
3911	{	3948	{
3912	if (!is_pair (y = caar (x)))	3949	if (!is_pair (y = caar (x)))
3913	break;	3950	break;
3914		3951
3915	for (; y != NIL; y = cdr (y))	3952	for (; y != NIL; y = cdr (y))
3916	{
3917	if (eqv (car (y), SCHEME_V->value))	3953	if (eqv (car (y), SCHEME_V->value))
3918	break;	3954	break;
3919	}
3920		3955
3921	if (y != NIL)	3956	if (y != NIL)
3922	break;	3957	break;
3923	}	3958	}
3924		3959
…		…
3944	s_goto (OP_BEGIN);	3979	s_goto (OP_BEGIN);
3945	else	3980	else
3946	s_return (NIL);	3981	s_return (NIL);
3947		3982
3948	case OP_PAPPLY: /* apply */	3983	case OP_PAPPLY: /* apply */
3949	SCHEME_V->code = car (SCHEME_V->args);	3984	SCHEME_V->code = car (args);
3950	SCHEME_V->args = list_star (SCHEME_A_ cdr (SCHEME_V->args));	3985	SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3951	/*SCHEME_V->args = cadr(SCHEME_V->args); */	3986	/*SCHEME_V->args = cadr(args); */
3952	s_goto (OP_APPLY);	3987	s_goto (OP_APPLY);
3953		3988
3954	case OP_PEVAL: /* eval */	3989	case OP_PEVAL: /* eval */
3955	if (cdr (SCHEME_V->args) != NIL)	3990	if (cdr (args) != NIL)
3956	SCHEME_V->envir = cadr (SCHEME_V->args);	3991	SCHEME_V->envir = cadr (args);
3957		3992
3958	SCHEME_V->code = car (SCHEME_V->args);	3993	SCHEME_V->code = car (args);
3959	s_goto (OP_EVAL);	3994	s_goto (OP_EVAL);
3960		3995
3961	case OP_CONTINUATION: /* call-with-current-continuation */	3996	case OP_CONTINUATION: /* call-with-current-continuation */
3962	SCHEME_V->code = car (SCHEME_V->args);	3997	SCHEME_V->code = car (args);
3963	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);	3998	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3964	s_goto (OP_APPLY);	3999	s_goto (OP_APPLY);
3965	}	4000	}
3966		4001
3967	return S_T;	4002	if (USE_ERROR_CHECKING) abort ();
3968	}	4003	}
3969		4004
3970	static pointer	4005	/* math, cxr */
		4006	ecb_hot static int
3971	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	4007	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3972	{	4008	{
3973	pointer x;	4009	pointer args = SCHEME_V->args;
		4010	pointer x = car (args);
3974	num v;	4011	num v;
3975		4012
		4013	switch (op)
		4014	{
3976	#if USE_MATH	4015	#if USE_MATH
3977	RVALUE dd;
3978	#endif
3979
3980	switch (op)
3981	{
3982	#if USE_MATH
3983
3984	case OP_INEX2EX: /* inexact->exact */	4016	case OP_INEX2EX: /* inexact->exact */
3985	x = car (SCHEME_V->args);
3986
3987	if (num_is_integer (x))	4017	if (!is_integer (x))
3988	s_return (x);	4018	{
3989	else if (modf (rvalue_unchecked (x), &dd) == 0.0)	4019	RVALUE r = rvalue_unchecked (x);
3990	s_return (mk_integer (SCHEME_A_ ivalue (x)));	4020
		4021	if (r == (RVALUE)(IVALUE)r)
		4022	x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
3991	else	4023	else
3992	Error_1 ("inexact->exact: not integral:", x);	4024	Error_1 ("inexact->exact: not integral:", x);
		4025	}
3993		4026
3994	case OP_EXP:	4027	s_return (x);
3995	x = car (SCHEME_V->args);	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))));
3996	s_return (mk_real (SCHEME_A_ exp (rvalue (x))));	4035	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
3997
3998	case OP_LOG:
3999	x = car (SCHEME_V->args);
4000	s_return (mk_real (SCHEME_A_ log (rvalue (x))));	4036	case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4001		4037	/ (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4002	case OP_SIN:
4003	x = car (SCHEME_V->args);
4004	s_return (mk_real (SCHEME_A_ sin (rvalue (x))));	4038	case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4005
4006	case OP_COS:
4007	x = car (SCHEME_V->args);
4008	s_return (mk_real (SCHEME_A_ cos (rvalue (x))));	4039	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4009
4010	case OP_TAN:
4011	x = car (SCHEME_V->args);
4012	s_return (mk_real (SCHEME_A_ tan (rvalue (x))));	4040	case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4013
4014	case OP_ASIN:
4015	x = car (SCHEME_V->args);
4016	s_return (mk_real (SCHEME_A_ asin (rvalue (x))));	4041	case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4017
4018	case OP_ACOS:
4019	x = car (SCHEME_V->args);
4020	s_return (mk_real (SCHEME_A_ acos (rvalue (x))));	4042	case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4021		4043
4022	case OP_ATAN:	4044	case OP_ATAN:
4023	x = car (SCHEME_V->args);
4024
4025	if (cdr (SCHEME_V->args) == NIL)
4026	s_return (mk_real (SCHEME_A_ atan (rvalue (x))));
4027	else
4028	{
4029	pointer y = cadr (SCHEME_V->args);
4030
4031	s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4032	}
4033
4034	case OP_SQRT:
4035	x = car (SCHEME_V->args);
4036	s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));	4045	s_return (mk_real (SCHEME_A_
		4046	cdr (args) == NIL
		4047	? atan (rvalue (x))
		4048	: atan2 (rvalue (x), rvalue (cadr (args)))));
4037		4049
4038	case OP_EXPT:	4050	case OP_EXPT:
4039	{	4051	{
4040	RVALUE result;	4052	RVALUE result;
4041	int real_result = 1;	4053	int real_result = 1;
4042	pointer y = cadr (SCHEME_V->args);	4054	pointer y = cadr (args);
4043		4055
4044	x = car (SCHEME_V->args);
4045
4046	if (num_is_integer (x) && num_is_integer (y))	4056	if (is_integer (x) && is_integer (y))
4047	real_result = 0;	4057	real_result = 0;
4048		4058
4049	/* This 'if' is an R5RS compatibility fix. */	4059	/* This 'if' is an R5RS compatibility fix. */
4050	/* NOTE: Remove this 'if' fix for R6RS. */	4060	/* NOTE: Remove this 'if' fix for R6RS. */
4051	if (rvalue (x) == 0 && rvalue (y) < 0)	4061	if (rvalue (x) == 0 && rvalue (y) < 0)
4052	result = 0.0;	4062	result = 0;
4053	else	4063	else
4054	result = pow (rvalue (x), rvalue (y));	4064	result = pow (rvalue (x), rvalue (y));
4055		4065
4056	/* Before returning integer result make sure we can. */	4066	/* Before returning integer result make sure we can. */
4057	/* If the test fails, result is too big for integer. */	4067	/* If the test fails, result is too big for integer. */
4058	if (!real_result)	4068	if (!real_result)
4059	{	4069	{
4060	long result_as_long = (long) result;	4070	long result_as_long = result;
4061		4071
4062	if (result != (RVALUE) result_as_long)	4072	if (result != result_as_long)
4063	real_result = 1;	4073	real_result = 1;
4064	}	4074	}
4065		4075
4066	if (real_result)	4076	if (real_result)
4067	s_return (mk_real (SCHEME_A_ result));	4077	s_return (mk_real (SCHEME_A_ result));
4068	else	4078	else
4069	s_return (mk_integer (SCHEME_A_ result));	4079	s_return (mk_integer (SCHEME_A_ result));
4070	}	4080	}
4071
4072	case OP_FLOOR:
4073	x = car (SCHEME_V->args);
4074	s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4075
4076	case OP_CEILING:
4077	x = car (SCHEME_V->args);
4078	s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4079
4080	case OP_TRUNCATE:
4081	{
4082	RVALUE rvalue_of_x;
4083
4084	x = car (SCHEME_V->args);
4085	rvalue_of_x = rvalue (x);
4086
4087	if (rvalue_of_x > 0)
4088	s_return (mk_real (SCHEME_A_ floor (rvalue_of_x)));
4089	else
4090	s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x)));
4091	}
4092
4093	case OP_ROUND:
4094	x = car (SCHEME_V->args);
4095
4096	if (num_is_integer (x))
4097	s_return (x);
4098
4099	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4100	#endif	4081	#endif
4101		4082
4102	case OP_ADD: /* + */	4083	case OP_ADD: /* + */
4103	v = num_zero;	4084	v = num_zero;
4104		4085
4105	for (x = SCHEME_V->args; x != NIL; x = cdr (x))	4086	for (x = args; x != NIL; x = cdr (x))
4106	v = num_add (v, nvalue (car (x)));	4087	v = num_op (NUM_ADD, v, nvalue (car (x)));
4107		4088
4108	s_return (mk_number (SCHEME_A_ v));	4089	s_return (mk_number (SCHEME_A_ v));
4109		4090
4110	case OP_MUL: /* * */	4091	case OP_MUL: /* * */
4111	v = num_one;	4092	v = num_one;
4112		4093
4113	for (x = SCHEME_V->args; x != NIL; x = cdr (x))	4094	for (x = args; x != NIL; x = cdr (x))
4114	v = num_mul (v, nvalue (car (x)));	4095	v = num_op (NUM_MUL, v, nvalue (car (x)));
4115		4096
4116	s_return (mk_number (SCHEME_A_ v));	4097	s_return (mk_number (SCHEME_A_ v));
4117		4098
4118	case OP_SUB: /* - */	4099	case OP_SUB: /* - */
4119	if (cdr (SCHEME_V->args) == NIL)	4100	if (cdr (args) == NIL)
4120	{	4101	{
4121	x = SCHEME_V->args;	4102	x = args;
4122	v = num_zero;	4103	v = num_zero;
4123	}	4104	}
4124	else	4105	else
4125	{	4106	{
4126	x = cdr (SCHEME_V->args);	4107	x = cdr (args);
4127	v = nvalue (car (SCHEME_V->args));	4108	v = nvalue (car (args));
4128	}	4109	}
4129		4110
4130	for (; x != NIL; x = cdr (x))	4111	for (; x != NIL; x = cdr (x))
4131	v = num_sub (v, nvalue (car (x)));	4112	v = num_op (NUM_SUB, v, nvalue (car (x)));
4132		4113
4133	s_return (mk_number (SCHEME_A_ v));	4114	s_return (mk_number (SCHEME_A_ v));
4134		4115
4135	case OP_DIV: /* / */	4116	case OP_DIV: /* / */
4136	if (cdr (SCHEME_V->args) == NIL)	4117	if (cdr (args) == NIL)
4137	{	4118	{
4138	x = SCHEME_V->args;	4119	x = args;
4139	v = num_one;	4120	v = num_one;
4140	}	4121	}
4141	else	4122	else
4142	{	4123	{
4143	x = cdr (SCHEME_V->args);	4124	x = cdr (args);
4144	v = nvalue (car (SCHEME_V->args));	4125	v = nvalue (car (args));
4145	}	4126	}
4146		4127
4147	for (; x != NIL; x = cdr (x))	4128	for (; x != NIL; x = cdr (x))
4148	{
4149	if (!is_zero_rvalue (rvalue (car (x))))	4129	if (!is_zero_rvalue (rvalue (car (x))))
4150	v = num_div (v, nvalue (car (x)));	4130	v = num_div (v, nvalue (car (x)));
4151	else	4131	else
4152	Error_0 ("/: division by zero");	4132	Error_0 ("/: division by zero");
4153	}
4154		4133
4155	s_return (mk_number (SCHEME_A_ v));	4134	s_return (mk_number (SCHEME_A_ v));
4156		4135
4157	case OP_INTDIV: /* quotient */	4136	case OP_INTDIV: /* quotient */
4158	if (cdr (SCHEME_V->args) == NIL)	4137	if (cdr (args) == NIL)
4159	{	4138	{
4160	x = SCHEME_V->args;	4139	x = args;
4161	v = num_one;	4140	v = num_one;
4162	}	4141	}
4163	else	4142	else
4164	{	4143	{
4165	x = cdr (SCHEME_V->args);	4144	x = cdr (args);
4166	v = nvalue (car (SCHEME_V->args));	4145	v = nvalue (car (args));
4167	}	4146	}
4168		4147
4169	for (; x != NIL; x = cdr (x))	4148	for (; x != NIL; x = cdr (x))
4170	{	4149	{
4171	if (ivalue (car (x)) != 0)	4150	if (ivalue (car (x)) != 0)
4172	v = num_intdiv (v, nvalue (car (x)));	4151	v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4173	else	4152	else
4174	Error_0 ("quotient: division by zero");	4153	Error_0 ("quotient: division by zero");
4175	}	4154	}
4176		4155
4177	s_return (mk_number (SCHEME_A_ v));	4156	s_return (mk_number (SCHEME_A_ v));
4178		4157
4179	case OP_REM: /* remainder */	4158	case OP_REM: /* remainder */
4180	v = nvalue (car (SCHEME_V->args));	4159	v = nvalue (x);
4181		4160
4182	if (ivalue (cadr (SCHEME_V->args)) != 0)	4161	if (ivalue (cadr (args)) != 0)
4183	v = num_rem (v, nvalue (cadr (SCHEME_V->args)));	4162	v = num_rem (v, nvalue (cadr (args)));
4184	else	4163	else
4185	Error_0 ("remainder: division by zero");	4164	Error_0 ("remainder: division by zero");
4186		4165
4187	s_return (mk_number (SCHEME_A_ v));	4166	s_return (mk_number (SCHEME_A_ v));
4188		4167
4189	case OP_MOD: /* modulo */	4168	case OP_MOD: /* modulo */
4190	v = nvalue (car (SCHEME_V->args));	4169	v = nvalue (x);
4191		4170
4192	if (ivalue (cadr (SCHEME_V->args)) != 0)	4171	if (ivalue (cadr (args)) != 0)
4193	v = num_mod (v, nvalue (cadr (SCHEME_V->args)));	4172	v = num_mod (v, nvalue (cadr (args)));
4194	else	4173	else
4195	Error_0 ("modulo: division by zero");	4174	Error_0 ("modulo: division by zero");
4196		4175
4197	s_return (mk_number (SCHEME_A_ v));	4176	s_return (mk_number (SCHEME_A_ v));
4198		4177
4199	case OP_CAR: /* car */	4178	/* the compiler will optimize this mess... */
4200	s_return (caar (SCHEME_V->args));	4179	case OP_CAR: op_car: s_return (car (x));
4201		4180	case OP_CDR: op_cdr: s_return (cdr (x));
4202	case OP_CDR: /* cdr */	4181	case OP_CAAR: op_caar: x = car (x); goto op_car;
4203	s_return (cdar (SCHEME_V->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;
4204		4209
4205	case OP_CONS: /* cons */	4210	case OP_CONS: /* cons */
4206	set_cdr (SCHEME_V->args, cadr (SCHEME_V->args));	4211	set_cdr (args, cadr (args));
4207	s_return (SCHEME_V->args);	4212	s_return (args);
4208		4213
4209	case OP_SETCAR: /* set-car! */	4214	case OP_SETCAR: /* set-car! */
4210	if (!is_immutable (car (SCHEME_V->args)))	4215	if (!is_immutable (x))
4211	{	4216	{
4212	set_car (car (SCHEME_V->args), cadr (SCHEME_V->args));	4217	set_car (x, cadr (args));
4213	s_return (car (SCHEME_V->args));	4218	s_return (car (args));
4214	}	4219	}
4215	else	4220	else
4216	Error_0 ("set-car!: unable to alter immutable pair");	4221	Error_0 ("set-car!: unable to alter immutable pair");
4217		4222
4218	case OP_SETCDR: /* set-cdr! */	4223	case OP_SETCDR: /* set-cdr! */
4219	if (!is_immutable (car (SCHEME_V->args)))	4224	if (!is_immutable (x))
4220	{	4225	{
4221	set_cdr (car (SCHEME_V->args), cadr (SCHEME_V->args));	4226	set_cdr (x, cadr (args));
4222	s_return (car (SCHEME_V->args));	4227	s_return (car (args));
4223	}	4228	}
4224	else	4229	else
4225	Error_0 ("set-cdr!: unable to alter immutable pair");	4230	Error_0 ("set-cdr!: unable to alter immutable pair");
4226		4231
4227	case OP_CHAR2INT: /* char->integer */	4232	case OP_CHAR2INT: /* char->integer */
4228	s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args))));	4233	s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x)));
4229		4234
4230	case OP_INT2CHAR: /* integer->char */	4235	case OP_INT2CHAR: /* integer->char */
4231	s_return (mk_character (SCHEME_A_ ivalue (car (SCHEME_V->args))));	4236	s_return (mk_character (SCHEME_A_ ivalue_unchecked (x)));
4232		4237
4233	case OP_CHARUPCASE:	4238	case OP_CHARUPCASE:
4234	{	4239	{
4235	unsigned char c = ivalue (car (SCHEME_V->args));	4240	unsigned char c = ivalue_unchecked (x);
4236	c = toupper (c);	4241	c = toupper (c);
4237	s_return (mk_character (SCHEME_A_ c));	4242	s_return (mk_character (SCHEME_A_ c));
4238	}	4243	}
4239		4244
4240	case OP_CHARDNCASE:	4245	case OP_CHARDNCASE:
4241	{	4246	{
4242	unsigned char c = ivalue (car (SCHEME_V->args));	4247	unsigned char c = ivalue_unchecked (x);
4243	c = tolower (c);	4248	c = tolower (c);
4244	s_return (mk_character (SCHEME_A_ c));	4249	s_return (mk_character (SCHEME_A_ c));
4245	}	4250	}
4246		4251
4247	case OP_STR2SYM: /* string->symbol */	4252	case OP_STR2SYM: /* string->symbol */
4248	s_return (mk_symbol (SCHEME_A_ strvalue (car (SCHEME_V->args))));	4253	s_return (mk_symbol (SCHEME_A_ strvalue (x)));
4249		4254
4250	case OP_STR2ATOM: /* string->atom */	4255	case OP_STR2ATOM: /* string->atom */
4251	{	4256	{
4252	char *s = strvalue (car (SCHEME_V->args));	4257	char *s = strvalue (x);
4253	long pf = 0;	4258	long pf = 0;
4254		4259
4255	if (cdr (SCHEME_V->args) != NIL)	4260	if (cdr (args) != NIL)
4256	{	4261	{
4257	/* we know cadr(SCHEME_V->args) is a natural number */	4262	/* we know cadr(args) is a natural number */
4258	/* see if it is 2, 8, 10, or 16, or error */	4263	/* see if it is 2, 8, 10, or 16, or error */
4259	pf = ivalue_unchecked (cadr (SCHEME_V->args));	4264	pf = ivalue_unchecked (cadr (args));
4260		4265
4261	if (pf == 16 || pf == 10 || pf == 8 || pf == 2)	4266	if (pf == 16 || pf == 10 || pf == 8 || pf == 2)
4262	{	4267	{
4263	/* base is OK */	4268	/* base is OK */
4264	}	4269	}
4265	else	4270	else
4266	pf = -1;	4271	pf = -1;
4267	}	4272	}
4268		4273
4269	if (pf < 0)	4274	if (pf < 0)
4270	Error_1 ("string->atom: bad base:", cadr (SCHEME_V->args));	4275	Error_1 ("string->atom: bad base:", cadr (args));
4271	else if (*s == '#') /* no use of base! */	4276	else if (*s == '#') /* no use of base! */
4272	s_return (mk_sharp_const (SCHEME_A_ s + 1));	4277	s_return (mk_sharp_const (SCHEME_A_ s + 1));
4273	else	4278	else
4274	{	4279	{
4275	if (pf == 0 || pf == 10)	4280	if (pf == 0 || pf == 10)
…		…
4286	}	4291	}
4287	}	4292	}
4288	}	4293	}
4289		4294
4290	case OP_SYM2STR: /* symbol->string */	4295	case OP_SYM2STR: /* symbol->string */
4291	x = mk_string (SCHEME_A_ symname (car (SCHEME_V->args)));	4296	x = mk_string (SCHEME_A_ symname (x));
4292	setimmutable (x);	4297	setimmutable (x);
4293	s_return (x);	4298	s_return (x);
4294		4299
4295	case OP_ATOM2STR: /* atom->string */	4300	case OP_ATOM2STR: /* atom->string */
4296	{	4301	{
4297	long pf = 0;	4302	long pf = 0;
4298		4303
4299	x = car (SCHEME_V->args);
4300
4301	if (cdr (SCHEME_V->args) != NIL)	4304	if (cdr (args) != NIL)
4302	{	4305	{
4303	/* we know cadr(SCHEME_V->args) is a natural number */	4306	/* we know cadr(args) is a natural number */
4304	/* see if it is 2, 8, 10, or 16, or error */	4307	/* see if it is 2, 8, 10, or 16, or error */
4305	pf = ivalue_unchecked (cadr (SCHEME_V->args));	4308	pf = ivalue_unchecked (cadr (args));
4306		4309
4307	if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2))	4310	if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2))
4308	{	4311	{
4309	/* base is OK */	4312	/* base is OK */
4310	}	4313	}
4311	else	4314	else
4312	pf = -1;	4315	pf = -1;
4313	}	4316	}
4314		4317
4315	if (pf < 0)	4318	if (pf < 0)
4316	Error_1 ("atom->string: bad base:", cadr (SCHEME_V->args));	4319	Error_1 ("atom->string: bad base:", cadr (args));
4317	else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x))	4320	else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x))
4318	{	4321	{
4319	char *p;	4322	char *p;
4320	int len;	4323	int len;
4321		4324
…		…
4326	Error_1 ("atom->string: not an atom:", x);	4329	Error_1 ("atom->string: not an atom:", x);
4327	}	4330	}
4328		4331
4329	case OP_MKSTRING: /* make-string */	4332	case OP_MKSTRING: /* make-string */
4330	{	4333	{
4331	int fill = ' ';	4334	int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' ';
4332	int len;	4335	int len = ivalue_unchecked (x);
4333		4336
4334	len = ivalue (car (SCHEME_V->args));
4335
4336	if (cdr (SCHEME_V->args) != NIL)
4337	fill = charvalue (cadr (SCHEME_V->args));
4338
4339	s_return (mk_empty_string (SCHEME_A_ len, (char) fill));	4337	s_return (mk_empty_string (SCHEME_A_ len, fill));
4340	}	4338	}
4341		4339
4342	case OP_STRLEN: /* string-length */	4340	case OP_STRLEN: /* string-length */
4343	s_return (mk_integer (SCHEME_A_ strlength (car (SCHEME_V->args))));	4341	s_return (mk_integer (SCHEME_A_ strlength (x)));
4344		4342
4345	case OP_STRREF: /* string-ref */	4343	case OP_STRREF: /* string-ref */
4346	{	4344	{
4347	char *str;	4345	char *str = strvalue (x);
4348	int index;
4349
4350	str = strvalue (car (SCHEME_V->args));
4351
4352	index = ivalue (cadr (SCHEME_V->args));	4346	int index = ivalue_unchecked (cadr (args));
4353		4347
4354	if (index >= strlength (car (SCHEME_V->args)))	4348	if (index >= strlength (x))
4355	Error_1 ("string-ref: out of bounds:", cadr (SCHEME_V->args));	4349	Error_1 ("string-ref: out of bounds:", cadr (args));
4356		4350
4357	s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index]));	4351	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4358	}	4352	}
4359		4353
4360	case OP_STRSET: /* string-set! */	4354	case OP_STRSET: /* string-set! */
4361	{	4355	{
4362	char *str;	4356	char *str = strvalue (x);
4363	int index;	4357	int index = ivalue_unchecked (cadr (args));
4364	int c;	4358	int c;
4365		4359
4366	if (is_immutable (car (SCHEME_V->args)))	4360	if (is_immutable (x))
4367	Error_1 ("string-set!: unable to alter immutable string:", car (SCHEME_V->args));	4361	Error_1 ("string-set!: unable to alter immutable string:", x);
4368		4362
4369	str = strvalue (car (SCHEME_V->args));
4370
4371	index = ivalue (cadr (SCHEME_V->args));
4372
4373	if (index >= strlength (car (SCHEME_V->args)))	4363	if (index >= strlength (x))
4374	Error_1 ("string-set!: out of bounds:", cadr (SCHEME_V->args));	4364	Error_1 ("string-set!: out of bounds:", cadr (args));
4375		4365
4376	c = charvalue (caddr (SCHEME_V->args));	4366	c = charvalue (caddr (args));
4377		4367
4378	str[index] = (char) c;	4368	str[index] = c;
4379	s_return (car (SCHEME_V->args));	4369	s_return (car (args));
4380	}	4370	}
4381		4371
4382	case OP_STRAPPEND: /* string-append */	4372	case OP_STRAPPEND: /* string-append */
4383	{	4373	{
4384	/* in 1.29 string-append was in Scheme in init.scm but was too slow */	4374	/* in 1.29 string-append was in Scheme in init.scm but was too slow */
4385	int len = 0;	4375	int len = 0;
4386	pointer newstr;	4376	pointer newstr;
4387	char *pos;	4377	char *pos;
4388		4378
4389	/* compute needed length for new string */	4379	/* compute needed length for new string */
4390	for (x = SCHEME_V->args; x != NIL; x = cdr (x))	4380	for (x = args; x != NIL; x = cdr (x))
4391	len += strlength (car (x));	4381	len += strlength (car (x));
4392		4382
4393	newstr = mk_empty_string (SCHEME_A_ len, ' ');	4383	newstr = mk_empty_string (SCHEME_A_ len, ' ');
4394		4384
4395	/* store the contents of the argument strings into the new string */	4385	/* store the contents of the argument strings into the new string */
4396	for (pos = strvalue (newstr), x = SCHEME_V->args; x != NIL; pos += strlength (car (x)), x = cdr (x))	4386	for (pos = strvalue (newstr), x = args; x != NIL; pos += strlength (car (x)), x = cdr (x))
4397	memcpy (pos, strvalue (car (x)), strlength (car (x)));	4387	memcpy (pos, strvalue (car (x)), strlength (car (x)));
4398		4388
4399	s_return (newstr);	4389	s_return (newstr);
4400	}	4390	}
4401		4391
4402	case OP_SUBSTR: /* substring */	4392	case OP_STRING_COPY: /* substring/string-copy */
4403	{	4393	{
4404	char *str;	4394	char *str = strvalue (x);
4405	int index0;	4395	int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4406	int index1;	4396	int index1;
4407	int len;	4397	int len;
4408		4398
4409	str = strvalue (car (SCHEME_V->args));
4410
4411	index0 = ivalue (cadr (SCHEME_V->args));
4412
4413	if (index0 > strlength (car (SCHEME_V->args)))	4399	if (index0 > strlength (x))
4414	Error_1 ("substring: start out of bounds:", cadr (SCHEME_V->args));	4400	Error_1 ("string->copy: start out of bounds:", cadr (args));
4415		4401
4416	if (cddr (SCHEME_V->args) != NIL)	4402	if (cddr (args) != NIL)
4417	{	4403	{
4418	index1 = ivalue (caddr (SCHEME_V->args));	4404	index1 = ivalue_unchecked (caddr (args));
4419		4405
4420	if (index1 > strlength (car (SCHEME_V->args)) || index1 < index0)	4406	if (index1 > strlength (x) || index1 < index0)
4421	Error_1 ("substring: end out of bounds:", caddr (SCHEME_V->args));	4407	Error_1 ("string->copy: end out of bounds:", caddr (args));
4422	}	4408	}
4423	else	4409	else
4424	index1 = strlength (car (SCHEME_V->args));	4410	index1 = strlength (x);
4425		4411
4426	len = index1 - index0;	4412	len = index1 - index0;
4427	x = mk_empty_string (SCHEME_A_ len, ' ');	4413	x = mk_counted_string (SCHEME_A_ str + index0, len);
4428	memcpy (strvalue (x), str + index0, len);
4429	strvalue (x)[len] = 0;
4430		4414
4431	s_return (x);	4415	s_return (x);
4432	}	4416	}
4433		4417
4434	case OP_VECTOR: /* vector */	4418	case OP_VECTOR: /* vector */
4435	{	4419	{
4436	int i;	4420	int i;
4437	pointer vec;	4421	pointer vec;
4438	int len = list_length (SCHEME_A_ SCHEME_V->args);	4422	int len = list_length (SCHEME_A_ args);
4439		4423
4440	if (len < 0)	4424	if (len < 0)
4441	Error_1 ("vector: not a proper list:", SCHEME_V->args);	4425	Error_1 ("vector: not a proper list:", args);
4442		4426
4443	vec = mk_vector (SCHEME_A_ len);	4427	vec = mk_vector (SCHEME_A_ len);
4444		4428
4445	#if USE_ERROR_CHECKING	4429	#if USE_ERROR_CHECKING
4446	if (SCHEME_V->no_memory)	4430	if (SCHEME_V->no_memory)
4447	s_return (S_SINK);	4431	s_return (S_SINK);
4448	#endif	4432	#endif
4449		4433
4450	for (x = SCHEME_V->args, i = 0; is_pair (x); x = cdr (x), i++)	4434	for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4451	set_vector_elem (vec, i, car (x));	4435	vector_set (vec, i, car (x));
4452		4436
4453	s_return (vec);	4437	s_return (vec);
4454	}	4438	}
4455		4439
4456	case OP_MKVECTOR: /* make-vector */	4440	case OP_MKVECTOR: /* make-vector */
4457	{	4441	{
4458	pointer fill = NIL;	4442	pointer fill = NIL;
4459	int len;
4460	pointer vec;	4443	pointer vec;
		4444	int len = ivalue_unchecked (x);
4461		4445
4462	len = ivalue (car (SCHEME_V->args));
4463
4464	if (cdr (SCHEME_V->args) != NIL)	4446	if (cdr (args) != NIL)
4465	fill = cadr (SCHEME_V->args);	4447	fill = cadr (args);
4466		4448
4467	vec = mk_vector (SCHEME_A_ len);	4449	vec = mk_vector (SCHEME_A_ len);
4468		4450
4469	#if USE_ERROR_CHECKING	4451	#if USE_ERROR_CHECKING
4470	if (SCHEME_V->no_memory)	4452	if (SCHEME_V->no_memory)
4471	s_return (S_SINK);	4453	s_return (S_SINK);
4472	#endif	4454	#endif
4473		4455
4474	if (fill != NIL)	4456	if (fill != NIL)
4475	fill_vector (vec, fill);	4457	fill_vector (vec, 0, fill);
4476		4458
4477	s_return (vec);	4459	s_return (vec);
4478	}	4460	}
4479		4461
4480	case OP_VECLEN: /* vector-length */	4462	case OP_VECLEN: /* vector-length */
4481	s_return (mk_integer (SCHEME_A_ veclength (car (SCHEME_V->args))));	4463	s_return (mk_integer (SCHEME_A_ veclength (x)));
		4464
		4465	case OP_VECRESIZE:
		4466	vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
		4467	s_return (x);
4482		4468
4483	case OP_VECREF: /* vector-ref */	4469	case OP_VECREF: /* vector-ref */
4484	{	4470	{
4485	int index;
4486
4487	index = ivalue (cadr (SCHEME_V->args));	4471	int index = ivalue_unchecked (cadr (args));
4488		4472
4489	if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)	4473	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4490	Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args));	4474	Error_1 ("vector-ref: out of bounds:", cadr (args));
4491		4475
4492	s_return (vector_elem (car (SCHEME_V->args), index));	4476	s_return (vector_get (x, index));
4493	}	4477	}
4494		4478
4495	case OP_VECSET: /* vector-set! */	4479	case OP_VECSET: /* vector-set! */
4496	{	4480	{
4497	int index;	4481	int index = ivalue_unchecked (cadr (args));
4498		4482
4499	if (is_immutable (car (SCHEME_V->args)))	4483	if (is_immutable (x))
4500	Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args));	4484	Error_1 ("vector-set!: unable to alter immutable vector:", x);
4501		4485
4502	index = ivalue (cadr (SCHEME_V->args));
4503
4504	if (index >= veclength (car (SCHEME_V->args)) && USE_ERROR_CHECKING)	4486	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4505	Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args));	4487	Error_1 ("vector-set!: out of bounds:", cadr (args));
4506		4488
4507	set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args));	4489	vector_set (x, index, caddr (args));
4508	s_return (car (SCHEME_V->args));	4490	s_return (x);
4509	}	4491	}
4510	}	4492	}
4511		4493
4512	return S_T;	4494	if (USE_ERROR_CHECKING) abort ();
4513	}	4495	}
4514		4496
4515	INTERFACE int	4497	/* relational ops */
4516	is_list (SCHEME_P_ pointer a)	4498	ecb_hot static int
		4499	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4517	{	4500	{
4518	return list_length (SCHEME_A_ a) >= 0;	4501	pointer x = SCHEME_V->args;
4519	}
4520		4502
4521	/* Result is:	4503	for (;;)
4522	proper list: length
4523	circular list: -1
4524	not even a pair: -2
4525	dotted list: -2 minus length before dot
4526	*/
4527	INTERFACE int
4528	list_length (SCHEME_P_ pointer a)
4529	{
4530	int i = 0;
4531	pointer slow, fast;
4532
4533	slow = fast = a;
4534
4535	while (1)
4536	{	4504	{
		4505	num v = nvalue (car (x));
		4506	x = cdr (x);
		4507
4537	if (fast == NIL)	4508	if (x == NIL)
4538	return i;	4509	break;
4539		4510
4540	if (!is_pair (fast))	4511	int r = num_cmp (v, nvalue (car (x)));
4541	return -2 - i;
4542		4512
4543	fast = cdr (fast);	4513	switch (op)
4544	++i;
4545
4546	if (fast == NIL)
4547	return i;
4548
4549	if (!is_pair (fast))
4550	return -2 - i;
4551
4552	++i;
4553	fast = cdr (fast);
4554
4555	/* Safe because we would have already returned if `fast'
4556	encountered a non-pair. */
4557	slow = cdr (slow);
4558
4559	if (fast == slow)
4560	{	4514	{
4561	/* the fast pointer has looped back around and caught up	4515	case OP_NUMEQ: r = r == 0; break;
4562	with the slow pointer, hence the structure is circular,	4516	case OP_LESS: r = r < 0; break;
4563	not of finite length, and therefore not a list */	4517	case OP_GRE: r = r > 0; break;
4564	return -1;	4518	case OP_LEQ: r = r <= 0; break;
		4519	case OP_GEQ: r = r >= 0; break;
4565	}	4520	}
4566	}
4567	}
4568		4521
4569	static pointer	4522	if (!r)
		4523	s_return (S_F);
		4524	}
		4525
		4526	s_return (S_T);
		4527	}
		4528
		4529	/* predicates */
		4530	ecb_hot static int
4570	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4531	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4571	{	4532	{
4572	pointer x;	4533	pointer args = SCHEME_V->args;
4573	num v;	4534	pointer a = car (args);
4574	int (*comp_func) (num, num);	4535	pointer d = cdr (args);
		4536	int r;
4575		4537
4576	switch (op)	4538	switch (op)
4577	{	4539	{
4578	case OP_NOT: /* not */	4540	case OP_NOT: /* not */ r = is_false (a) ; break;
4579	s_retbool (is_false (car (SCHEME_V->args)));	4541	case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break;
		4542	case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
		4543	case OP_NULLP: /* null? */ r = a == NIL ; break;
		4544	case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
		4545	case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break;
		4546	case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
		4547	case OP_STRINGP: /* string? */ r = is_string (a) ; break;
		4548	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
		4549	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
		4550	case OP_CHARP: /* char? */ r = is_character (a) ; break;
4580		4551
4581	case OP_BOOLP: /* boolean? */
4582	s_retbool (car (SCHEME_V->args) == S_F || car (SCHEME_V->args) == S_T);
4583
4584	case OP_EOFOBJP: /* boolean? */
4585	s_retbool (car (SCHEME_V->args) == S_EOF);
4586
4587	case OP_NULLP: /* null? */
4588	s_retbool (car (SCHEME_V->args) == NIL);
4589
4590	case OP_NUMEQ: /* = */
4591	case OP_LESS: /* < */
4592	case OP_GRE: /* > */
4593	case OP_LEQ: /* <= */
4594	case OP_GEQ: /* >= */
4595	switch (op)
4596	{
4597	case OP_NUMEQ:
4598	comp_func = num_eq;
4599	break;
4600
4601	case OP_LESS:
4602	comp_func = num_lt;
4603	break;
4604
4605	case OP_GRE:
4606	comp_func = num_gt;
4607	break;
4608
4609	case OP_LEQ:
4610	comp_func = num_le;
4611	break;
4612
4613	case OP_GEQ:
4614	comp_func = num_ge;
4615	break;
4616	}
4617
4618	x = SCHEME_V->args;
4619	v = nvalue (car (x));
4620	x = cdr (x);
4621
4622	for (; x != NIL; x = cdr (x))
4623	{
4624	if (!comp_func (v, nvalue (car (x))))
4625	s_retbool (0);
4626
4627	v = nvalue (car (x));
4628	}
4629
4630	s_retbool (1);
4631
4632	case OP_SYMBOLP: /* symbol? */
4633	s_retbool (is_symbol (car (SCHEME_V->args)));
4634
4635	case OP_NUMBERP: /* number? */
4636	s_retbool (is_number (car (SCHEME_V->args)));
4637
4638	case OP_STRINGP: /* string? */
4639	s_retbool (is_string (car (SCHEME_V->args)));
4640
4641	case OP_INTEGERP: /* integer? */
4642	s_retbool (is_integer (car (SCHEME_V->args)));
4643
4644	case OP_REALP: /* real? */
4645	s_retbool (is_number (car (SCHEME_V->args))); /* All numbers are real */
4646
4647	case OP_CHARP: /* char? */
4648	s_retbool (is_character (car (SCHEME_V->args)));
4649	#if USE_CHAR_CLASSIFIERS	4552	#if USE_CHAR_CLASSIFIERS
4650		4553	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4651	case OP_CHARAP: /* char-alphabetic? */	4554	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4652	s_retbool (Cisalpha (ivalue (car (SCHEME_V->args))));	4555	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
4653		4556	case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break;
4654	case OP_CHARNP: /* char-numeric? */	4557	case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break;
4655	s_retbool (Cisdigit (ivalue (car (SCHEME_V->args))));
4656
4657	case OP_CHARWP: /* char-whitespace? */
4658	s_retbool (Cisspace (ivalue (car (SCHEME_V->args))));
4659
4660	case OP_CHARUP: /* char-upper-case? */
4661	s_retbool (Cisupper (ivalue (car (SCHEME_V->args))));
4662
4663	case OP_CHARLP: /* char-lower-case? */
4664	s_retbool (Cislower (ivalue (car (SCHEME_V->args))));
4665	#endif	4558	#endif
		4559
4666	#if USE_PORTS	4560	#if USE_PORTS
4667		4561	case OP_PORTP: /* port? */ r = is_port (a) ; break;
4668	case OP_PORTP: /* port? */
4669	s_retbool (is_port (car (SCHEME_V->args)));
4670
4671	case OP_INPORTP: /* input-port? */	4562	case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
4672	s_retbool (is_inport (car (SCHEME_V->args)));
4673
4674	case OP_OUTPORTP: /* output-port? */	4563	case OP_OUTPORTP: /* output-port? */ r = is_outport (a); break;
4675	s_retbool (is_outport (car (SCHEME_V->args)));
4676	#endif	4564	#endif
4677		4565
4678	case OP_PROCP: /* procedure? */	4566	case OP_PROCP: /* procedure? */
4679		4567
4680	/*--	4568	/*--
4681	* continuation should be procedure by the example	4569	* continuation should be procedure by the example
4682	* (call-with-current-continuation procedure?) ==> #t	4570	* (call-with-current-continuation procedure?) ==> #t
4683	* in R^3 report sec. 6.9	4571	* in R^3 report sec. 6.9
4684	*/	4572	*/
4685	s_retbool (is_proc (car (SCHEME_V->args)) || is_closure (car (SCHEME_V->args))	4573	r = is_proc (a) || is_closure (a) || is_continuation (a) || is_foreign (a);
4686	|| is_continuation (car (SCHEME_V->args)) || is_foreign (car (SCHEME_V->args)));	4574	break;
4687		4575
4688	case OP_PAIRP: /* pair? */	4576	case OP_PAIRP: /* pair? */ r = is_pair (a) ; break;
4689	s_retbool (is_pair (car (SCHEME_V->args)));	4577	case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break;
4690		4578	case OP_ENVP: /* environment? */ r = is_environment (a) ; break;
4691	case OP_LISTP: /* list? */	4579	case OP_VECTORP: /* vector? */ r = is_vector (a) ; break;
4692	s_retbool (list_length (SCHEME_A_ car (SCHEME_V->args)) >= 0);	4580	case OP_EQ: /* eq? */ r = a == cadr (args) ; break;
4693		4581	case OP_EQV: /* eqv? */ r = eqv (a, cadr (args)) ; break;
4694	case OP_ENVP: /* environment? */
4695	s_retbool (is_environment (car (SCHEME_V->args)));
4696
4697	case OP_VECTORP: /* vector? */
4698	s_retbool (is_vector (car (SCHEME_V->args)));
4699
4700	case OP_EQ: /* eq? */
4701	s_retbool (car (SCHEME_V->args) == cadr (SCHEME_V->args));
4702
4703	case OP_EQV: /* eqv? */
4704	s_retbool (eqv (car (SCHEME_V->args), cadr (SCHEME_V->args)));
4705	}	4582	}
4706		4583
4707	return S_T;	4584	s_retbool (r);
4708	}	4585	}
4709		4586
4710	static pointer	4587	/* promises, list ops, ports */
		4588	ecb_hot static int
4711	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4589	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4712	{	4590	{
		4591	pointer args = SCHEME_V->args;
		4592	pointer a = car (args);
4713	pointer x, y;	4593	pointer x, y;
4714		4594
4715	switch (op)	4595	switch (op)
4716	{	4596	{
4717	case OP_FORCE: /* force */	4597	case OP_FORCE: /* force */
4718	SCHEME_V->code = car (SCHEME_V->args);	4598	SCHEME_V->code = a;
4719		4599
4720	if (is_promise (SCHEME_V->code))	4600	if (is_promise (SCHEME_V->code))
4721	{	4601	{
4722	/* Should change type to closure here */	4602	/* Should change type to closure here */
4723	s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code);	4603	s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code);
…		…
4726	}	4606	}
4727	else	4607	else
4728	s_return (SCHEME_V->code);	4608	s_return (SCHEME_V->code);
4729		4609
4730	case OP_SAVE_FORCED: /* Save forced value replacing promise */	4610	case OP_SAVE_FORCED: /* Save forced value replacing promise */
4731	memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell));	4611	*CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4732	s_return (SCHEME_V->value);	4612	s_return (SCHEME_V->value);
4733		4613
4734	#if USE_PORTS	4614	#if USE_PORTS
		4615
		4616	case OP_EOF_OBJECT: /* eof-object */
		4617	s_return (S_EOF);
4735		4618
4736	case OP_WRITE: /* write */	4619	case OP_WRITE: /* write */
4737	case OP_DISPLAY: /* display */	4620	case OP_DISPLAY: /* display */
4738	case OP_WRITE_CHAR: /* write-char */	4621	case OP_WRITE_CHAR: /* write-char */
4739	if (is_pair (cdr (SCHEME_V->args)))	4622	if (is_pair (cdr (SCHEME_V->args)))
…		…
4744	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);	4627	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4745	SCHEME_V->outport = cadr (SCHEME_V->args);	4628	SCHEME_V->outport = cadr (SCHEME_V->args);
4746	}	4629	}
4747	}	4630	}
4748		4631
4749	SCHEME_V->args = car (SCHEME_V->args);	4632	SCHEME_V->args = a;
4750		4633
4751	if (op == OP_WRITE)	4634	if (op == OP_WRITE)
4752	SCHEME_V->print_flag = 1;	4635	SCHEME_V->print_flag = 1;
4753	else	4636	else
4754	SCHEME_V->print_flag = 0;	4637	SCHEME_V->print_flag = 0;
4755		4638
4756	s_goto (OP_P0LIST);	4639	s_goto (OP_P0LIST);
4757		4640
4758	case OP_NEWLINE: /* newline */	4641	case OP_NEWLINE: /* newline */
4759	if (is_pair (SCHEME_V->args))	4642	if (is_pair (args))
4760	{	4643	{
4761	if (car (SCHEME_V->args) != SCHEME_V->outport)	4644	if (a != SCHEME_V->outport)
4762	{	4645	{
4763	x = cons (SCHEME_V->outport, NIL);	4646	x = cons (SCHEME_V->outport, NIL);
4764	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);	4647	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4765	SCHEME_V->outport = car (SCHEME_V->args);	4648	SCHEME_V->outport = a;
4766	}	4649	}
4767	}	4650	}
4768		4651
4769	putstr (SCHEME_A_ "\n");	4652	putstr (SCHEME_A_ "\n");
4770	s_return (S_T);	4653	s_return (S_T);
4771	#endif	4654	#endif
4772		4655
4773	case OP_ERR0: /* error */	4656	case OP_ERR0: /* error */
4774	SCHEME_V->retcode = -1;	4657	SCHEME_V->retcode = -1;
4775		4658
4776	if (!is_string (car (SCHEME_V->args)))	4659	if (!is_string (a))
4777	{	4660	{
4778	SCHEME_V->args = cons (mk_string (SCHEME_A_ " -- "), SCHEME_V->args);	4661	args = cons (mk_string (SCHEME_A_ " -- "), args);
4779	setimmutable (car (SCHEME_V->args));	4662	setimmutable (car (args));
4780	}	4663	}
4781		4664
4782	putstr (SCHEME_A_ "Error: ");	4665	putstr (SCHEME_A_ "Error: ");
4783	putstr (SCHEME_A_ strvalue (car (SCHEME_V->args)));	4666	putstr (SCHEME_A_ strvalue (car (args)));
4784	SCHEME_V->args = cdr (SCHEME_V->args);	4667	SCHEME_V->args = cdr (args);
4785	s_goto (OP_ERR1);	4668	s_goto (OP_ERR1);
4786		4669
4787	case OP_ERR1: /* error */	4670	case OP_ERR1: /* error */
4788	putstr (SCHEME_A_ " ");	4671	putstr (SCHEME_A_ " ");
4789		4672
4790	if (SCHEME_V->args != NIL)	4673	if (args != NIL)
4791	{	4674	{
4792	s_save (SCHEME_A_ OP_ERR1, cdr (SCHEME_V->args), NIL);	4675	s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4793	SCHEME_V->args = car (SCHEME_V->args);	4676	SCHEME_V->args = a;
4794	SCHEME_V->print_flag = 1;	4677	SCHEME_V->print_flag = 1;
4795	s_goto (OP_P0LIST);	4678	s_goto (OP_P0LIST);
4796	}	4679	}
4797	else	4680	else
4798	{	4681	{
4799	putstr (SCHEME_A_ "\n");	4682	putstr (SCHEME_A_ "\n");
4800		4683
4801	if (SCHEME_V->interactive_repl)	4684	if (SCHEME_V->interactive_repl)
4802	s_goto (OP_T0LVL);	4685	s_goto (OP_T0LVL);
4803	else	4686	else
4804	return NIL;	4687	return -1;
4805	}	4688	}
4806		4689
4807	case OP_REVERSE: /* reverse */	4690	case OP_REVERSE: /* reverse */
4808	s_return (reverse (SCHEME_A_ car (SCHEME_V->args)));	4691	s_return (reverse (SCHEME_A_ a));
4809		4692
4810	case OP_LIST_STAR: /* list* */	4693	case OP_LIST_STAR: /* list* */
4811	s_return (list_star (SCHEME_A_ SCHEME_V->args));	4694	s_return (list_star (SCHEME_A_ SCHEME_V->args));
4812		4695
4813	case OP_APPEND: /* append */	4696	case OP_APPEND: /* append */
4814	x = NIL;	4697	x = NIL;
4815	y = SCHEME_V->args;	4698	y = args;
4816		4699
4817	if (y == x)	4700	if (y == x)
4818	s_return (x);	4701	s_return (x);
4819		4702
4820	/* cdr() in the while condition is not a typo. If car() */	4703	/* cdr() in the while condition is not a typo. If car() */
…		…
4831	s_return (reverse_in_place (SCHEME_A_ car (y), x));	4714	s_return (reverse_in_place (SCHEME_A_ car (y), x));
4832		4715
4833	#if USE_PLIST	4716	#if USE_PLIST
4834		4717
4835	case OP_PUT: /* put */	4718	case OP_PUT: /* put */
4836	if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args)))	4719	if (!hasprop (a) || !hasprop (cadr (args)))
4837	Error_0 ("illegal use of put");	4720	Error_0 ("illegal use of put");
4838		4721
4839	for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x))	4722	for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
4840	{	4723	{
4841	if (caar (x) == y)	4724	if (caar (x) == y)
4842	break;	4725	break;
4843	}	4726	}
4844		4727
4845	if (x != NIL)	4728	if (x != NIL)
4846	cdar (x) = caddr (SCHEME_V->args);	4729	cdar (x) = caddr (args);
4847	else	4730	else
4848	symprop (car (SCHEME_V->args)) = cons (cons (y, caddr (SCHEME_V->args)), symprop (car (SCHEME_V->args)));	4731	symprop (a) = cons (cons (y, caddr (args)), symprop (a));
4849		4732
4850	s_return (S_T);	4733	s_return (S_T);
4851		4734
4852	case OP_GET: /* get */	4735	case OP_GET: /* get */
4853	if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args)))	4736	if (!hasprop (a) || !hasprop (cadr (args)))
4854	Error_0 ("illegal use of get");	4737	Error_0 ("illegal use of get");
4855		4738
4856	for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x))	4739	for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
4857	if (caar (x) == y)	4740	if (caar (x) == y)
4858	break;	4741	break;
4859		4742
4860	if (x != NIL)	4743	if (x != NIL)
4861	s_return (cdar (x));	4744	s_return (cdar (x));
…		…
4863	s_return (NIL);	4746	s_return (NIL);
4864		4747
4865	#endif /* USE_PLIST */	4748	#endif /* USE_PLIST */
4866		4749
4867	case OP_QUIT: /* quit */	4750	case OP_QUIT: /* quit */
4868	if (is_pair (SCHEME_V->args))	4751	if (is_pair (args))
4869	SCHEME_V->retcode = ivalue (car (SCHEME_V->args));	4752	SCHEME_V->retcode = ivalue (a);
4870		4753
4871	return NIL;	4754	return -1;
4872		4755
4873	case OP_GC: /* gc */	4756	case OP_GC: /* gc */
4874	gc (SCHEME_A_ NIL, NIL);	4757	gc (SCHEME_A_ NIL, NIL);
4875	s_return (S_T);	4758	s_return (S_T);
4876		4759
4877	case OP_GCVERB: /* gc-verbose */	4760	case OP_GCVERB: /* gc-verbose */
4878	{	4761	{
4879	int was = SCHEME_V->gc_verbose;	4762	int was = SCHEME_V->gc_verbose;
4880		4763
4881	SCHEME_V->gc_verbose = (car (SCHEME_V->args) != S_F);	4764	SCHEME_V->gc_verbose = (a != S_F);
4882	s_retbool (was);	4765	s_retbool (was);
4883	}	4766	}
4884		4767
4885	case OP_NEWSEGMENT: /* new-segment */	4768	case OP_NEWSEGMENT: /* new-segment */
		4769	#if 0
4886	if (!is_pair (SCHEME_V->args) || !is_number (car (SCHEME_V->args)))	4770	if (!is_pair (args) || !is_number (a))
4887	Error_0 ("new-segment: argument must be a number");	4771	Error_0 ("new-segment: argument must be a number");
4888		4772	#endif
4889	alloc_cellseg (SCHEME_A_ (int)ivalue (car (SCHEME_V->args)));	4773	s_retbool (alloc_cellseg (SCHEME_A));
4890
4891	s_return (S_T);
4892		4774
4893	case OP_OBLIST: /* oblist */	4775	case OP_OBLIST: /* oblist */
4894	s_return (oblist_all_symbols (SCHEME_A));	4776	s_return (oblist_all_symbols (SCHEME_A));
4895		4777
4896	#if USE_PORTS	4778	#if USE_PORTS
…		…
4921	case OP_OPEN_INOUTFILE:	4803	case OP_OPEN_INOUTFILE:
4922	prop = port_input | port_output;	4804	prop = port_input | port_output;
4923	break;	4805	break;
4924	}	4806	}
4925		4807
4926	p = port_from_filename (SCHEME_A_ strvalue (car (SCHEME_V->args)), prop);	4808	p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4927		4809
4928	if (p == NIL)	4810	s_return (p == NIL ? S_F : p);
4929	s_return (S_F);
4930
4931	s_return (p);
4932	}	4811	}
4933		4812
4934	# if USE_STRING_PORTS	4813	# if USE_STRING_PORTS
4935		4814
4936	case OP_OPEN_INSTRING: /* open-input-string */	4815	case OP_OPEN_INSTRING: /* open-input-string */
…		…
4948	case OP_OPEN_INOUTSTRING:	4827	case OP_OPEN_INOUTSTRING:
4949	prop = port_input | port_output;	4828	prop = port_input | port_output;
4950	break;	4829	break;
4951	}	4830	}
4952		4831
4953	p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)),	4832	p = port_from_string (SCHEME_A_ strvalue (a),
4954	strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), prop);	4833	strvalue (a) + strlength (a), prop);
4955		4834
4956	if (p == NIL)	4835	s_return (p == NIL ? S_F : p);
4957	s_return (S_F);
4958
4959	s_return (p);
4960	}	4836	}
4961		4837
4962	case OP_OPEN_OUTSTRING: /* open-output-string */	4838	case OP_OPEN_OUTSTRING: /* open-output-string */
4963	{	4839	{
4964	pointer p;	4840	pointer p;
4965		4841
4966	if (car (SCHEME_V->args) == NIL)	4842	if (a == NIL)
4967	{
4968	p = port_from_scratch (SCHEME_A);	4843	p = port_from_scratch (SCHEME_A);
4969
4970	if (p == NIL)
4971	s_return (S_F);
4972	}
4973	else	4844	else
4974	{
4975	p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)),	4845	p = port_from_string (SCHEME_A_ strvalue (a),
4976	strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), port_output);	4846	strvalue (a) + strlength (a), port_output);
4977		4847
4978	if (p == NIL)	4848	s_return (p == NIL ? S_F : p);
4979	s_return (S_F);
4980	}
4981
4982	s_return (p);
4983	}	4849	}
4984		4850
4985	case OP_GET_OUTSTRING: /* get-output-string */	4851	case OP_GET_OUTSTRING: /* get-output-string */
4986	{	4852	{
4987	port *p;	4853	port *p = port (a);
4988		4854
4989	if ((p = car (SCHEME_V->args)->object.port)->kind & port_string)	4855	if (p->kind & port_string)
4990	{	4856	{
4991	off_t size;	4857	off_t size;
4992	char *str;	4858	char *str;
4993		4859
4994	size = p->rep.string.curr - p->rep.string.start + 1;	4860	size = p->rep.string.curr - p->rep.string.start + 1;
…		…
5010	}	4876	}
5011		4877
5012	# endif	4878	# endif
5013		4879
5014	case OP_CLOSE_INPORT: /* close-input-port */	4880	case OP_CLOSE_INPORT: /* close-input-port */
5015	port_close (SCHEME_A_ car (SCHEME_V->args), port_input);	4881	port_close (SCHEME_A_ a, port_input);
5016	s_return (S_T);	4882	s_return (S_T);
5017		4883
5018	case OP_CLOSE_OUTPORT: /* close-output-port */	4884	case OP_CLOSE_OUTPORT: /* close-output-port */
5019	port_close (SCHEME_A_ car (SCHEME_V->args), port_output);	4885	port_close (SCHEME_A_ a, port_output);
5020	s_return (S_T);	4886	s_return (S_T);
5021	#endif	4887	#endif
5022		4888
5023	case OP_INT_ENV: /* interaction-environment */	4889	case OP_INT_ENV: /* interaction-environment */
5024	s_return (SCHEME_V->global_env);	4890	s_return (SCHEME_V->global_env);
…		…
5026	case OP_CURR_ENV: /* current-environment */	4892	case OP_CURR_ENV: /* current-environment */
5027	s_return (SCHEME_V->envir);	4893	s_return (SCHEME_V->envir);
5028		4894
5029	}	4895	}
5030		4896
5031	return S_T;	4897	if (USE_ERROR_CHECKING) abort ();
5032	}	4898	}
5033		4899
5034	static pointer	4900	/* reading */
		4901	ecb_cold static int
5035	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4902	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
5036	{	4903	{
		4904	pointer args = SCHEME_V->args;
5037	pointer x;	4905	pointer x;
5038		4906
5039	if (SCHEME_V->nesting != 0)	4907	if (SCHEME_V->nesting != 0)
5040	{	4908	{
5041	int n = SCHEME_V->nesting;	4909	int n = SCHEME_V->nesting;
…		…
5048	switch (op)	4916	switch (op)
5049	{	4917	{
5050	/* ========== reading part ========== */	4918	/* ========== reading part ========== */
5051	#if USE_PORTS	4919	#if USE_PORTS
5052	case OP_READ:	4920	case OP_READ:
5053	if (!is_pair (SCHEME_V->args))	4921	if (!is_pair (args))
5054	s_goto (OP_READ_INTERNAL);	4922	s_goto (OP_READ_INTERNAL);
5055		4923
5056	if (!is_inport (car (SCHEME_V->args)))	4924	if (!is_inport (car (args)))
5057	Error_1 ("read: not an input port:", car (SCHEME_V->args));	4925	Error_1 ("read: not an input port:", car (args));
5058		4926
5059	if (car (SCHEME_V->args) == SCHEME_V->inport)	4927	if (car (args) == SCHEME_V->inport)
5060	s_goto (OP_READ_INTERNAL);	4928	s_goto (OP_READ_INTERNAL);
5061		4929
5062	x = SCHEME_V->inport;	4930	x = SCHEME_V->inport;
5063	SCHEME_V->inport = car (SCHEME_V->args);	4931	SCHEME_V->inport = car (args);
5064	x = cons (x, NIL);	4932	x = cons (x, NIL);
5065	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);	4933	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
5066	s_goto (OP_READ_INTERNAL);	4934	s_goto (OP_READ_INTERNAL);
5067		4935
5068	case OP_READ_CHAR: /* read-char */	4936	case OP_READ_CHAR: /* read-char */
5069	case OP_PEEK_CHAR: /* peek-char */	4937	case OP_PEEK_CHAR: /* peek-char */
5070	{	4938	{
5071	int c;	4939	int c;
5072		4940
5073	if (is_pair (SCHEME_V->args))	4941	if (is_pair (args))
5074	{	4942	{
5075	if (car (SCHEME_V->args) != SCHEME_V->inport)	4943	if (car (args) != SCHEME_V->inport)
5076	{	4944	{
5077	x = SCHEME_V->inport;	4945	x = SCHEME_V->inport;
5078	x = cons (x, NIL);	4946	x = cons (x, NIL);
5079	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);	4947	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
5080	SCHEME_V->inport = car (SCHEME_V->args);	4948	SCHEME_V->inport = car (args);
5081	}	4949	}
5082	}	4950	}
5083		4951
5084	c = inchar (SCHEME_A);	4952	c = inchar (SCHEME_A);
5085		4953
…		…
5095	case OP_CHAR_READY: /* char-ready? */	4963	case OP_CHAR_READY: /* char-ready? */
5096	{	4964	{
5097	pointer p = SCHEME_V->inport;	4965	pointer p = SCHEME_V->inport;
5098	int res;	4966	int res;
5099		4967
5100	if (is_pair (SCHEME_V->args))	4968	if (is_pair (args))
5101	p = car (SCHEME_V->args);	4969	p = car (args);
5102		4970
5103	res = p->object.port->kind & port_string;	4971	res = port (p)->kind & port_string;
5104		4972
5105	s_retbool (res);	4973	s_retbool (res);
5106	}	4974	}
5107		4975
5108	case OP_SET_INPORT: /* set-input-port */	4976	case OP_SET_INPORT: /* set-input-port */
5109	SCHEME_V->inport = car (SCHEME_V->args);	4977	SCHEME_V->inport = car (args);
5110	s_return (SCHEME_V->value);	4978	s_return (SCHEME_V->value);
5111		4979
5112	case OP_SET_OUTPORT: /* set-output-port */	4980	case OP_SET_OUTPORT: /* set-output-port */
5113	SCHEME_V->outport = car (SCHEME_V->args);	4981	SCHEME_V->outport = car (args);
5114	s_return (SCHEME_V->value);	4982	s_return (SCHEME_V->value);
5115	#endif	4983	#endif
5116		4984
5117	case OP_RDSEXPR:	4985	case OP_RDSEXPR:
5118	switch (SCHEME_V->tok)	4986	switch (SCHEME_V->tok)
…		…
5167	s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);	5035	s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
5168	SCHEME_V->tok = token (SCHEME_A);	5036	SCHEME_V->tok = token (SCHEME_A);
5169	s_goto (OP_RDSEXPR);	5037	s_goto (OP_RDSEXPR);
5170		5038
5171	case TOK_ATOM:	5039	case TOK_ATOM:
5172	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)));
5173		5050
5174	case TOK_DQUOTE:	5051	case TOK_DQUOTE:
5175	x = readstrexp (SCHEME_A);	5052	x = readstrexp (SCHEME_A_ '"');
5176		5053
5177	if (x == S_F)	5054	if (x == S_F)
5178	Error_0 ("Error reading string");	5055	Error_0 ("Error reading string");
5179		5056
5180	setimmutable (x);	5057	setimmutable (x);
…		…
5192	s_goto (OP_EVAL);	5069	s_goto (OP_EVAL);
5193	}	5070	}
5194	}	5071	}
5195		5072
5196	case TOK_SHARP_CONST:	5073	case TOK_SHARP_CONST:
5197	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)
5198	Error_0 ("undefined sharp expression");	5075	Error_0 ("undefined sharp expression");
5199	else	5076	else
5200	s_return (x);	5077	s_return (x);
5201		5078
5202	default:	5079	default:
…		…
5204	}	5081	}
5205		5082
5206	break;	5083	break;
5207		5084
5208	case OP_RDLIST:	5085	case OP_RDLIST:
5209	SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args);	5086	SCHEME_V->args = cons (SCHEME_V->value, args);
5210	SCHEME_V->tok = token (SCHEME_A);	5087	SCHEME_V->tok = token (SCHEME_A);
5211		5088
5212	switch (SCHEME_V->tok)	5089	switch (SCHEME_V->tok)
5213	{	5090	{
5214	case TOK_EOF:	5091	case TOK_EOF:
…		…
5242	case OP_RDDOT:	5119	case OP_RDDOT:
5243	if (token (SCHEME_A) != TOK_RPAREN)	5120	if (token (SCHEME_A) != TOK_RPAREN)
5244	Error_0 ("syntax error: illegal dot expression");	5121	Error_0 ("syntax error: illegal dot expression");
5245		5122
5246	SCHEME_V->nesting_stack[SCHEME_V->file_i]--;	5123	SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5247	s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args));	5124	s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args));
5248		5125
5249	case OP_RDQUOTE:	5126	case OP_RDQUOTE:
5250	s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));	5127	s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));
5251		5128
5252	case OP_RDQQUOTE:	5129	case OP_RDQQUOTE:
…		…
5274	SCHEME_V->args = SCHEME_V->value;	5151	SCHEME_V->args = SCHEME_V->value;
5275	s_goto (OP_VECTOR);	5152	s_goto (OP_VECTOR);
5276		5153
5277	/* ========== printing part ========== */	5154	/* ========== printing part ========== */
5278	case OP_P0LIST:	5155	case OP_P0LIST:
5279	if (is_vector (SCHEME_V->args))	5156	if (is_vector (args))
5280	{	5157	{
5281	putstr (SCHEME_A_ "#(");	5158	putstr (SCHEME_A_ "#(");
5282	SCHEME_V->args = cons (SCHEME_V->args, mk_integer (SCHEME_A_ 0));	5159	SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0));
5283	s_goto (OP_PVECFROM);	5160	s_goto (OP_PVECFROM);
5284	}	5161	}
5285	else if (is_environment (SCHEME_V->args))	5162	else if (is_environment (args))
5286	{	5163	{
5287	putstr (SCHEME_A_ "#<ENVIRONMENT>");	5164	putstr (SCHEME_A_ "#<ENVIRONMENT>");
5288	s_return (S_T);	5165	s_return (S_T);
5289	}	5166	}
5290	else if (!is_pair (SCHEME_V->args))	5167	else if (!is_pair (args))
5291	{	5168	{
5292	printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag);	5169	printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5293	s_return (S_T);	5170	s_return (S_T);
5294	}	5171	}
5295	else if (car (SCHEME_V->args) == SCHEME_V->QUOTE && ok_abbrev (cdr (SCHEME_V->args)))	5172	else
5296	{	5173	{
		5174	pointer a = car (args);
		5175	pointer b = cdr (args);
		5176	int ok_abbr = ok_abbrev (b);
		5177	SCHEME_V->args = car (b);
		5178
		5179	if (a == SCHEME_V->QUOTE && ok_abbr)
5297	putstr (SCHEME_A_ "'");	5180	putstr (SCHEME_A_ "'");
5298	SCHEME_V->args = cadr (SCHEME_V->args);	5181	else if (a == SCHEME_V->QQUOTE && ok_abbr)
		5182	putstr (SCHEME_A_ "`");
		5183	else if (a == SCHEME_V->UNQUOTE && ok_abbr)
		5184	putstr (SCHEME_A_ ",");
		5185	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
		5186	putstr (SCHEME_A_ ",@");
		5187	else
		5188	{
		5189	putstr (SCHEME_A_ "(");
		5190	s_save (SCHEME_A_ OP_P1LIST, b, NIL);
		5191	SCHEME_V->args = a;
		5192	}
		5193
5299	s_goto (OP_P0LIST);	5194	s_goto (OP_P0LIST);
5300	}	5195	}
5301	else if (car (SCHEME_V->args) == SCHEME_V->QQUOTE && ok_abbrev (cdr (SCHEME_V->args)))	5196
		5197	case OP_P1LIST:
		5198	if (is_pair (args))
5302	{	5199	{
		5200	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5303	putstr (SCHEME_A_ "`");	5201	putstr (SCHEME_A_ " ");
5304	SCHEME_V->args = cadr (SCHEME_V->args);	5202	SCHEME_V->args = car (args);
5305	s_goto (OP_P0LIST);	5203	s_goto (OP_P0LIST);
5306	}	5204	}
5307	else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTE && ok_abbrev (cdr (SCHEME_V->args)))
5308	{
5309	putstr (SCHEME_A_ ",");
5310	SCHEME_V->args = cadr (SCHEME_V->args);
5311	s_goto (OP_P0LIST);
5312	}
5313	else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTESP && ok_abbrev (cdr (SCHEME_V->args)))
5314	{
5315	putstr (SCHEME_A_ ",@");
5316	SCHEME_V->args = cadr (SCHEME_V->args);
5317	s_goto (OP_P0LIST);
5318	}
5319	else
5320	{
5321	putstr (SCHEME_A_ "(");
5322	s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
5323	SCHEME_V->args = car (SCHEME_V->args);
5324	s_goto (OP_P0LIST);
5325	}
5326
5327	case OP_P1LIST:
5328	if (is_pair (SCHEME_V->args))
5329	{
5330	s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
5331	putstr (SCHEME_A_ " ");
5332	SCHEME_V->args = car (SCHEME_V->args);
5333	s_goto (OP_P0LIST);
5334	}
5335	else if (is_vector (SCHEME_V->args))	5205	else if (is_vector (args))
5336	{	5206	{
5337	s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);	5207	s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);
5338	putstr (SCHEME_A_ " . ");	5208	putstr (SCHEME_A_ " . ");
5339	s_goto (OP_P0LIST);	5209	s_goto (OP_P0LIST);
5340	}	5210	}
5341	else	5211	else
5342	{	5212	{
5343	if (SCHEME_V->args != NIL)	5213	if (args != NIL)
5344	{	5214	{
5345	putstr (SCHEME_A_ " . ");	5215	putstr (SCHEME_A_ " . ");
5346	printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag);	5216	printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5347	}	5217	}
5348		5218
5349	putstr (SCHEME_A_ ")");	5219	putstr (SCHEME_A_ ")");
5350	s_return (S_T);	5220	s_return (S_T);
5351	}	5221	}
5352		5222
5353	case OP_PVECFROM:	5223	case OP_PVECFROM:
5354	{	5224	{
5355	int i = ivalue_unchecked (cdr (SCHEME_V->args));	5225	int i = ivalue_unchecked (cdr (args));
5356	pointer vec = car (SCHEME_V->args);	5226	pointer vec = car (args);
5357	int len = veclength (vec);	5227	int len = veclength (vec);
5358		5228
5359	if (i == len)	5229	if (i == len)
5360	{	5230	{
5361	putstr (SCHEME_A_ ")");	5231	putstr (SCHEME_A_ ")");
5362	s_return (S_T);	5232	s_return (S_T);
5363	}	5233	}
5364	else	5234	else
5365	{	5235	{
5366	pointer elem = vector_elem (vec, i);	5236	pointer elem = vector_get (vec, i);
5367		5237
5368	ivalue_unchecked (cdr (SCHEME_V->args)) = i + 1;	5238	ivalue_unchecked (cdr (args)) = i + 1;
5369	s_save (SCHEME_A_ OP_PVECFROM, SCHEME_V->args, NIL);	5239	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5370	SCHEME_V->args = elem;	5240	SCHEME_V->args = elem;
5371		5241
5372	if (i > 0)	5242	if (i > 0)
5373	putstr (SCHEME_A_ " ");	5243	putstr (SCHEME_A_ " ");
5374		5244
5375	s_goto (OP_P0LIST);	5245	s_goto (OP_P0LIST);
5376	}	5246	}
5377	}	5247	}
5378	}	5248	}
5379		5249
5380	return S_T;	5250	if (USE_ERROR_CHECKING) abort ();
5381	}	5251	}
5382		5252
5383	static pointer	5253	/* list ops */
		5254	ecb_hot static int
5384	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5255	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5385	{	5256	{
		5257	pointer args = SCHEME_V->args;
		5258	pointer a = car (args);
5386	pointer x, y;	5259	pointer x, y;
5387		5260
5388	switch (op)	5261	switch (op)
5389	{	5262	{
5390	case OP_LIST_LENGTH: /* length *//* a.k */	5263	case OP_LIST_LENGTH: /* length *//* a.k */
5391	{	5264	{
5392	long v = list_length (SCHEME_A_ car (SCHEME_V->args));	5265	long v = list_length (SCHEME_A_ a);
5393		5266
5394	if (v < 0)	5267	if (v < 0)
5395	Error_1 ("length: not a list:", car (SCHEME_V->args));	5268	Error_1 ("length: not a list:", a);
5396		5269
5397	s_return (mk_integer (SCHEME_A_ v));	5270	s_return (mk_integer (SCHEME_A_ v));
5398	}	5271	}
5399		5272
5400	case OP_ASSQ: /* assq *//* a.k */	5273	case OP_ASSQ: /* assq *//* a.k */
5401	x = car (SCHEME_V->args);	5274	x = a;
5402		5275
5403	for (y = cadr (SCHEME_V->args); is_pair (y); y = cdr (y))	5276	for (y = cadr (args); is_pair (y); y = cdr (y))
5404	{	5277	{
5405	if (!is_pair (car (y)))	5278	if (!is_pair (car (y)))
5406	Error_0 ("unable to handle non pair element");	5279	Error_0 ("unable to handle non pair element");
5407		5280
5408	if (x == caar (y))	5281	if (x == caar (y))
…		…
5414	else	5287	else
5415	s_return (S_F);	5288	s_return (S_F);
5416		5289
5417		5290
5418	case OP_GET_CLOSURE: /* get-closure-code *//* a.k */	5291	case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5419	SCHEME_V->args = car (SCHEME_V->args);	5292	SCHEME_V->args = a;
5420		5293
5421	if (SCHEME_V->args == NIL)	5294	if (SCHEME_V->args == NIL)
5422	s_return (S_F);	5295	s_return (S_F);
5423	else if (is_closure (SCHEME_V->args))	5296	else if (is_closure (SCHEME_V->args))
5424	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));	5297	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
…		…
5429		5302
5430	case OP_CLOSUREP: /* closure? */	5303	case OP_CLOSUREP: /* closure? */
5431	/*	5304	/*
5432	* Note, macro object is also a closure.	5305	* Note, macro object is also a closure.
5433	* Therefore, (closure? <#MACRO>) ==> #t	5306	* Therefore, (closure? <#MACRO>) ==> #t
		5307	* (schmorp) well, obviously not, fix? TODO
5434	*/	5308	*/
5435	s_retbool (is_closure (car (SCHEME_V->args)));	5309	s_retbool (is_closure (a));
5436		5310
5437	case OP_MACROP: /* macro? */	5311	case OP_MACROP: /* macro? */
5438	s_retbool (is_macro (car (SCHEME_V->args)));	5312	s_retbool (is_macro (a));
5439	}	5313	}
5440		5314
5441	return S_T; /* NOTREACHED */	5315	if (USE_ERROR_CHECKING) abort ();
5442	}	5316	}
5443		5317
		5318	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5444	typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);	5319	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5445		5320
5446	typedef int (*test_predicate) (pointer);	5321	typedef int (*test_predicate)(pointer);
5447	static int	5322
		5323	ecb_hot static int
5448	is_any (pointer p)	5324	tst_any (pointer p)
5449	{	5325	{
5450	return 1;	5326	return 1;
5451	}	5327	}
5452		5328
5453	static int	5329	ecb_hot static int
5454	is_nonneg (pointer p)	5330	tst_inonneg (pointer p)
5455	{	5331	{
5456	return ivalue (p) >= 0 && is_integer (p);	5332	return is_integer (p) && ivalue_unchecked (p) >= 0;
		5333	}
		5334
		5335	ecb_hot static int
		5336	tst_is_list (SCHEME_P_ pointer p)
		5337	{
		5338	return p == NIL || is_pair (p);
5457	}	5339	}
5458		5340
5459	/* Correspond carefully with following defines! */	5341	/* Correspond carefully with following defines! */
5460	static struct	5342	static struct
5461	{	5343	{
5462	test_predicate fct;	5344	test_predicate fct;
5463	const char *kind;	5345	const char *kind;
5464	} tests[] =	5346	} tests[] = {
5465	{	5347	{ tst_any , 0 },
5466	{ 0, 0}, /* unused */	5348	{ is_string , "string" },
5467	{ is_any, 0},	5349	{ is_symbol , "symbol" },
5468	{ is_string, "string" },	5350	{ is_port , "port" },
5469	{ is_symbol, "symbol" },
5470	{ is_port, "port" },
5471	{ is_inport, "input port" },	5351	{ is_inport , "input port" },
5472	{ is_outport, "output port" },	5352	{ is_outport , "output port" },
5473	{ is_environment, "environment" },	5353	{ is_environment, "environment" },
5474	{ is_pair, "pair" },	5354	{ is_pair , "pair" },
5475	{ 0, "pair or '()" },	5355	{ 0 , "pair or '()" },
5476	{ is_character, "character" },	5356	{ is_character , "character" },
5477	{ is_vector, "vector" },	5357	{ is_vector , "vector" },
5478	{ is_number, "number" },	5358	{ is_number , "number" },
5479	{ is_integer, "integer" },	5359	{ is_integer , "integer" },
5480	{ is_nonneg, "non-negative integer" }	5360	{ tst_inonneg , "non-negative integer" }
5481	};	5361	};
5482		5362
5483	#define TST_NONE 0	5363	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5484	#define TST_ANY "\001"	5364	#define TST_ANY "\001"
5485	#define TST_STRING "\002"	5365	#define TST_STRING "\002"
5486	#define TST_SYMBOL "\003"	5366	#define TST_SYMBOL "\003"
5487	#define TST_PORT "\004"	5367	#define TST_PORT "\004"
5488	#define TST_INPORT "\005"	5368	#define TST_INPORT "\005"
5489	#define TST_OUTPORT "\006"	5369	#define TST_OUTPORT "\006"
5490	#define TST_ENVIRONMENT "\007"	5370	#define TST_ENVIRONMENT "\007"
5491	#define TST_PAIR "\010"	5371	#define TST_PAIR "\010"
5492	#define TST_LIST "\011"	5372	#define TST_LIST "\011"
5493	#define TST_CHAR "\012"	5373	#define TST_CHAR "\012"
5494	#define TST_VECTOR "\013"	5374	#define TST_VECTOR "\013"
5495	#define TST_NUMBER "\014"	5375	#define TST_NUMBER "\014"
5496	#define TST_INTEGER "\015"	5376	#define TST_INTEGER "\015"
5497	#define TST_NATURAL "\016"	5377	#define TST_NATURAL "\016"
		5378
		5379	#define INF_ARG 0xff
		5380	#define UNNAMED_OP ""
		5381
		5382	static const char opnames[] =
		5383	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
		5384	#include "opdefines.h"
		5385	#undef OP_DEF
		5386	;
		5387
		5388	ecb_cold static const char *
		5389	opname (int idx)
		5390	{
		5391	const char *name = opnames;
		5392
		5393	/* should do this at compile time, but would require external program, right? */
		5394	while (idx--)
		5395	name += strlen (name) + 1;
		5396
		5397	return *name ? name : "ILLEGAL";
		5398	}
		5399
		5400	ecb_cold static const char *
		5401	procname (pointer x)
		5402	{
		5403	return opname (procnum (x));
		5404	}
5498		5405
5499	typedef struct	5406	typedef struct
5500	{	5407	{
5501	dispatch_func func;	5408	uint8_t func;
5502	char *name;	5409	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
		5410	uint8_t builtin;
		5411	#if USE_ERROR_CHECKING
5503	int min_arity;	5412	uint8_t min_arity;
5504	int max_arity;	5413	uint8_t max_arity;
5505	char *arg_tests_encoding;	5414	char arg_tests_encoding[3];
		5415	#endif
5506	} op_code_info;	5416	} op_code_info;
5507		5417
5508	#define INF_ARG 0xffff
5509
5510	static op_code_info dispatch_table[] = {	5418	static const op_code_info dispatch_table[] = {
5511	#define OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},	5419	#if USE_ERROR_CHECKING
		5420	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
		5421	#else
		5422	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 },
		5423	#endif
5512	#include "opdefines.h"	5424	#include "opdefines.h"
		5425	#undef OP_DEF
5513	{0}	5426	{0}
5514	};	5427	};
5515		5428
5516	static const char *
5517	procname (pointer x)
5518	{
5519	int n = procnum (x);
5520	const char *name = dispatch_table[n].name;
5521
5522	if (name == 0)
5523	name = "ILLEGAL!";
5524
5525	return name;
5526	}
5527
5528	/* kernel of this interpreter */	5429	/* kernel of this interpreter */
5529	static void	5430	ecb_hot static void
5530	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5431	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5531	{	5432	{
5532	SCHEME_V->op = op;	5433	SCHEME_V->op = op;
5533		5434
5534	for (;;)	5435	for (;;)
5535	{	5436	{
5536	op_code_info *pcd = dispatch_table + SCHEME_V->op;	5437	const op_code_info *pcd = dispatch_table + SCHEME_V->op;
5537		5438
5538	#if USE_ERROR_CHECKING	5439	#if USE_ERROR_CHECKING
5539	if (pcd->name) /* if built-in function, check arguments */	5440	if (pcd->builtin) /* if built-in function, check arguments */
5540	{	5441	{
5541	int ok = 1;
5542	char msg[STRBUFFSIZE];	5442	char msg[STRBUFFSIZE];
5543	int n = list_length (SCHEME_A_ SCHEME_V->args);	5443	int n = list_length (SCHEME_A_ SCHEME_V->args);
5544		5444
5545	/* Check number of arguments */	5445	/* Check number of arguments */
5546	if (n < pcd->min_arity)	5446	if (ecb_expect_false (n < pcd->min_arity))
5547	{	5447	{
5548	ok = 0;
5549	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5448	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5550	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);	5449	opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
		5450	xError_1 (SCHEME_A_ msg, 0);
		5451	continue;
5551	}	5452	}
5552		5453	else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
5553	if (ok && n > pcd->max_arity)
5554	{	5454	{
5555	ok = 0;
5556	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5455	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5557	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);	5456	opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
		5457	xError_1 (SCHEME_A_ msg, 0);
		5458	continue;
5558	}	5459	}
5559		5460	else
5560	if (ok)
5561	{	5461	{
5562	if (pcd->arg_tests_encoding)	5462	if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */
5563	{	5463	{
5564	int i = 0;	5464	int i = 0;
5565	int j;	5465	int j;
5566	const char *t = pcd->arg_tests_encoding;	5466	const char *t = pcd->arg_tests_encoding;
5567	pointer arglist = SCHEME_V->args;	5467	pointer arglist = SCHEME_V->args;
5568		5468
5569	do	5469	do
5570	{	5470	{
5571	pointer arg = car (arglist);	5471	pointer arg = car (arglist);
5572		5472
5573	j = (int) t[0];	5473	j = t[0];
5574		5474
		5475	/*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */
5575	if (j == TST_LIST[0])	5476	if (j == TST_LIST[0])
5576	{	5477	{
5577	if (arg != NIL && !is_pair (arg))	5478	if (!tst_is_list (SCHEME_A_ arg))
5578	break;	5479	break;
5579	}	5480	}
5580	else	5481	else
5581	{	5482	{
5582	if (!tests[j].fct (arg))	5483	if (!tests[j - 1].fct (arg))
5583	break;	5484	break;
5584	}	5485	}
5585		5486
5586	if (t[1] != 0) /* last test is replicated as necessary */	5487	if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */
5587	t++;	5488	t++;
5588		5489
5589	arglist = cdr (arglist);	5490	arglist = cdr (arglist);
5590	i++;	5491	i++;
5591	}	5492	}
5592	while (i < n);	5493	while (i < n);
5593		5494
5594	if (i < n)	5495	if (i < n)
5595	{	5496	{
5596	ok = 0;
5597	snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind);	5497	snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind);
		5498	xError_1 (SCHEME_A_ msg, 0);
		5499	continue;
5598	}	5500	}
5599	}	5501	}
5600	}	5502	}
5601
5602	if (!ok)
5603	{
5604	if (xError_1 (SCHEME_A_ msg, 0) == NIL)
5605	return;
5606
5607	pcd = dispatch_table + SCHEME_V->op;
5608	}
5609	}	5503	}
5610	#endif	5504	#endif
5611		5505
5612	ok_to_freely_gc (SCHEME_A);	5506	ok_to_freely_gc (SCHEME_A);
5613		5507
5614	if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL)	5508	static const dispatch_func dispatch_funcs[] = {
		5509	opexe_0,
		5510	opexe_1,
		5511	opexe_2,
		5512	opexe_3,
		5513	opexe_4,
		5514	opexe_5,
		5515	opexe_6,
		5516	};
		5517
		5518	if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5615	return;	5519	return;
5616		5520
5617	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	5521	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5618	{	5522	{
5619	xwrstr ("No memory!\n");	5523	putstr (SCHEME_A_ "No memory!\n");
5620	return;	5524	return;
5621	}	5525	}
5622	}	5526	}
5623	}	5527	}
5624		5528
5625	/* ========== Initialization of internal keywords ========== */	5529	/* ========== Initialization of internal keywords ========== */
5626		5530
5627	static void	5531	ecb_cold static void
5628	assign_syntax (SCHEME_P_ const char *name)	5532	assign_syntax (SCHEME_P_ const char *name)
5629	{	5533	{
5630	pointer x = oblist_add_by_name (SCHEME_A_ name);	5534	pointer x = oblist_add_by_name (SCHEME_A_ name);
5631	set_typeflag (x, typeflag (x) | T_SYNTAX);	5535	set_typeflag (x, typeflag (x) | T_SYNTAX);
5632	}	5536	}
5633		5537
5634	static void	5538	ecb_cold static void
5635	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)	5539	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5636	{	5540	{
5637	pointer x = mk_symbol (SCHEME_A_ name);	5541	pointer x = mk_symbol (SCHEME_A_ name);
5638	pointer y = mk_proc (SCHEME_A_ op);	5542	pointer y = mk_proc (SCHEME_A_ op);
5639	new_slot_in_env (SCHEME_A_ x, y);	5543	new_slot_in_env (SCHEME_A_ x, y);
…		…
5643	mk_proc (SCHEME_P_ enum scheme_opcodes op)	5547	mk_proc (SCHEME_P_ enum scheme_opcodes op)
5644	{	5548	{
5645	pointer y = get_cell (SCHEME_A_ NIL, NIL);	5549	pointer y = get_cell (SCHEME_A_ NIL, NIL);
5646	set_typeflag (y, (T_PROC | T_ATOM));	5550	set_typeflag (y, (T_PROC | T_ATOM));
5647	ivalue_unchecked (y) = op;	5551	ivalue_unchecked (y) = op;
5648	set_num_integer (y);
5649	return y;	5552	return y;
5650	}	5553	}
5651		5554
5652	/* 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! */
5653	static int	5556	ecb_hot static int
5654	syntaxnum (pointer p)	5557	syntaxnum (pointer p)
5655	{	5558	{
5656	const char *s = strvalue (car (p));	5559	const char *s = strvalue (p);
5657		5560
5658	switch (strlength (car (p)))	5561	switch (strlength (p))
5659	{	5562	{
5660	case 2:	5563	case 2:
5661	if (s[0] == 'i')	5564	if (s[0] == 'i')
5662	return OP_IF0; /* if */	5565	return OP_IF0; /* if */
5663	else	5566	else
…		…
5677		5580
5678	case 'd':	5581	case 'd':
5679	return OP_COND0; /* cond */	5582	return OP_COND0; /* cond */
5680		5583
5681	case '*':	5584	case '*':
5682	return OP_LET0AST; /* let* */	5585	return OP_LET0AST;/* let* */
5683		5586
5684	default:	5587	default:
5685	return OP_SET0; /* set! */	5588	return OP_SET0; /* set! */
5686	}	5589	}
5687		5590
…		…
5709		5612
5710	case 'f':	5613	case 'f':
5711	return OP_DEF0; /* define */	5614	return OP_DEF0; /* define */
5712		5615
5713	default:	5616	default:
5714	return OP_LET0REC; /* letrec */	5617	return OP_LET0REC;/* letrec */
5715	}	5618	}
5716		5619
5717	default:	5620	default:
5718	return OP_C0STREAM; /* cons-stream */	5621	return OP_C0STREAM; /* cons-stream */
5719	}	5622	}
5720	}	5623	}
5721		5624
5722	#if USE_MULTIPLICITY	5625	#if USE_MULTIPLICITY
5723	scheme *	5626	ecb_cold scheme *
5724	scheme_init_new ()	5627	scheme_init_new ()
5725	{	5628	{
5726	scheme *sc = malloc (sizeof (scheme));	5629	scheme *sc = malloc (sizeof (scheme));
5727		5630
5728	if (!scheme_init (SCHEME_A))	5631	if (!scheme_init (SCHEME_A))
…		…
5733	else	5636	else
5734	return sc;	5637	return sc;
5735	}	5638	}
5736	#endif	5639	#endif
5737		5640
5738	int	5641	ecb_cold int
5739	scheme_init (SCHEME_P)	5642	scheme_init (SCHEME_P)
5740	{	5643	{
5741	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	5644	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5742	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));
5743		5652
5744	num_set_fixnum (num_zero, 1);	5653	num_set_fixnum (num_zero, 1);
5745	num_set_ivalue (num_zero, 0);	5654	num_set_ivalue (num_zero, 0);
5746	num_set_fixnum (num_one, 1);	5655	num_set_fixnum (num_one, 1);
5747	num_set_ivalue (num_one, 1);	5656	num_set_ivalue (num_one, 1);
…		…
5759	SCHEME_V->save_inport = NIL;	5668	SCHEME_V->save_inport = NIL;
5760	SCHEME_V->loadport = NIL;	5669	SCHEME_V->loadport = NIL;
5761	SCHEME_V->nesting = 0;	5670	SCHEME_V->nesting = 0;
5762	SCHEME_V->interactive_repl = 0;	5671	SCHEME_V->interactive_repl = 0;
5763		5672
5764	if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS)	5673	if (!alloc_cellseg (SCHEME_A))
5765	{	5674	{
5766	#if USE_ERROR_CHECKING	5675	#if USE_ERROR_CHECKING
5767	SCHEME_V->no_memory = 1;	5676	SCHEME_V->no_memory = 1;
5768	return 0;	5677	return 0;
5769	#endif	5678	#endif
…		…
5816		5725
5817	for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)	5726	for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
5818	assign_syntax (SCHEME_A_ syntax_names[i]);	5727	assign_syntax (SCHEME_A_ syntax_names[i]);
5819	}	5728	}
5820		5729
		5730	// TODO: should iterate via strlen, to avoid n² complexity
5821	for (i = 0; i < n; i++)	5731	for (i = 0; i < n; i++)
5822	if (dispatch_table[i].name != 0)	5732	if (dispatch_table[i].builtin)
5823	assign_proc (SCHEME_A_ i, dispatch_table[i].name);	5733	assign_proc (SCHEME_A_ i, opname (i));
5824		5734
5825	/* initialization of global pointers to special symbols */	5735	/* initialization of global pointers to special symbols */
5826	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");	5736	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5827	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");	5737	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5828	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");	5738	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
…		…
5836		5746
5837	return !SCHEME_V->no_memory;	5747	return !SCHEME_V->no_memory;
5838	}	5748	}
5839		5749
5840	#if USE_PORTS	5750	#if USE_PORTS
5841	void	5751	ecb_cold void
5842	scheme_set_input_port_file (SCHEME_P_ int fin)	5752	scheme_set_input_port_file (SCHEME_P_ int fin)
5843	{	5753	{
5844	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);	5754	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5845	}	5755	}
5846		5756
5847	void	5757	ecb_cold void
5848	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)
5849	{	5759	{
5850	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);
5851	}	5761	}
5852		5762
5853	void	5763	ecb_cold void
5854	scheme_set_output_port_file (SCHEME_P_ int fout)	5764	scheme_set_output_port_file (SCHEME_P_ int fout)
5855	{	5765	{
5856	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);	5766	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5857	}	5767	}
5858		5768
5859	void	5769	ecb_cold void
5860	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)
5861	{	5771	{
5862	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);
5863	}	5773	}
5864	#endif	5774	#endif
5865		5775
5866	void	5776	ecb_cold void
5867	scheme_set_external_data (SCHEME_P_ void *p)	5777	scheme_set_external_data (SCHEME_P_ void *p)
5868	{	5778	{
5869	SCHEME_V->ext_data = p;	5779	SCHEME_V->ext_data = p;
5870	}	5780	}
5871		5781
5872	void	5782	ecb_cold void
5873	scheme_deinit (SCHEME_P)	5783	scheme_deinit (SCHEME_P)
5874	{	5784	{
5875	int i;	5785	int i;
5876		5786
5877	#if SHOW_ERROR_LINE	5787	#if SHOW_ERROR_LINE
…		…
5919	}	5829	}
5920	}	5830	}
5921	#endif	5831	#endif
5922	}	5832	}
5923		5833
5924	void	5834	ecb_cold void
5925	scheme_load_file (SCHEME_P_ int fin)	5835	scheme_load_file (SCHEME_P_ int fin)
5926	{	5836	{
5927	scheme_load_named_file (SCHEME_A_ fin, 0);	5837	scheme_load_named_file (SCHEME_A_ fin, 0);
5928	}	5838	}
5929		5839
5930	void	5840	ecb_cold void
5931	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)	5841	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5932	{	5842	{
5933	dump_stack_reset (SCHEME_A);	5843	dump_stack_reset (SCHEME_A);
5934	SCHEME_V->envir = SCHEME_V->global_env;	5844	SCHEME_V->envir = SCHEME_V->global_env;
5935	SCHEME_V->file_i = 0;	5845	SCHEME_V->file_i = 0;
…		…
5962		5872
5963	if (SCHEME_V->retcode == 0)	5873	if (SCHEME_V->retcode == 0)
5964	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5874	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5965	}	5875	}
5966		5876
5967	void	5877	ecb_cold void
5968	scheme_load_string (SCHEME_P_ const char *cmd)	5878	scheme_load_string (SCHEME_P_ const char *cmd)
5969	{	5879	{
5970	dump_stack_reset (SCHEME_A);	5880	dump_stack_reset (SCHEME_A);
5971	SCHEME_V->envir = SCHEME_V->global_env;	5881	SCHEME_V->envir = SCHEME_V->global_env;
5972	SCHEME_V->file_i = 0;	5882	SCHEME_V->file_i = 0;
5973	SCHEME_V->load_stack[0].kind = port_input | port_string;	5883	SCHEME_V->load_stack[0].kind = port_input | port_string;
5974	SCHEME_V->load_stack[0].rep.string.start = (char *) cmd; /* This func respects const */	5884	SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5975	SCHEME_V->load_stack[0].rep.string.past_the_end = (char *) cmd + strlen (cmd);	5885	SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5976	SCHEME_V->load_stack[0].rep.string.curr = (char *) cmd;	5886	SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5977	#if USE_PORTS	5887	#if USE_PORTS
5978	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);	5888	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5979	#endif	5889	#endif
5980	SCHEME_V->retcode = 0;	5890	SCHEME_V->retcode = 0;
5981	SCHEME_V->interactive_repl = 0;	5891	SCHEME_V->interactive_repl = 0;
…		…
5986		5896
5987	if (SCHEME_V->retcode == 0)	5897	if (SCHEME_V->retcode == 0)
5988	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5898	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5989	}	5899	}
5990		5900
5991	void	5901	ecb_cold void
5992	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)	5902	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5993	{	5903	{
5994	pointer x;	5904	pointer x;
5995		5905
5996	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);	5906	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
…		…
6001	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);	5911	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
6002	}	5912	}
6003		5913
6004	#if !STANDALONE	5914	#if !STANDALONE
6005		5915
6006	void	5916	ecb_cold void
6007	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)	5917	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
6008	{	5918	{
6009	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));
6010	}	5920	}
6011		5921
6012	void	5922	ecb_cold void
6013	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)
6014	{	5924	{
6015	int i;	5925	int i;
6016		5926
6017	for (i = 0; i < count; i++)	5927	for (i = 0; i < count; i++)
6018	scheme_register_foreign_func (SCHEME_A_ list + i);	5928	scheme_register_foreign_func (SCHEME_A_ list + i);
6019	}	5929	}
6020		5930
6021	pointer	5931	ecb_cold pointer
6022	scheme_apply0 (SCHEME_P_ const char *procname)	5932	scheme_apply0 (SCHEME_P_ const char *procname)
6023	{	5933	{
6024	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));
6025	}	5935	}
6026		5936
6027	void	5937	ecb_cold void
6028	save_from_C_call (SCHEME_P)	5938	save_from_C_call (SCHEME_P)
6029	{	5939	{
6030	pointer saved_data = cons (car (S_SINK),	5940	pointer saved_data = cons (car (S_SINK),
6031	cons (SCHEME_V->envir,	5941	cons (SCHEME_V->envir,
6032	SCHEME_V->dump));	5942	SCHEME_V->dump));
…		…
6036	/* 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
6037	directly resume pre-C-call operations. */	5947	directly resume pre-C-call operations. */
6038	dump_stack_reset (SCHEME_A);	5948	dump_stack_reset (SCHEME_A);
6039	}	5949	}
6040		5950
6041	void	5951	ecb_cold void
6042	restore_from_C_call (SCHEME_P)	5952	restore_from_C_call (SCHEME_P)
6043	{	5953	{
6044	set_car (S_SINK, caar (SCHEME_V->c_nest));	5954	set_car (S_SINK, caar (SCHEME_V->c_nest));
6045	SCHEME_V->envir = cadar (SCHEME_V->c_nest);	5955	SCHEME_V->envir = cadar (SCHEME_V->c_nest);
6046	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));	5956	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
6047	/* Pop */	5957	/* Pop */
6048	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);	5958	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
6049	}	5959	}
6050		5960
6051	/* "func" and "args" are assumed to be already eval'ed. */	5961	/* "func" and "args" are assumed to be already eval'ed. */
6052	pointer	5962	ecb_cold pointer
6053	scheme_call (SCHEME_P_ pointer func, pointer args)	5963	scheme_call (SCHEME_P_ pointer func, pointer args)
6054	{	5964	{
6055	int old_repl = SCHEME_V->interactive_repl;	5965	int old_repl = SCHEME_V->interactive_repl;
6056		5966
6057	SCHEME_V->interactive_repl = 0;	5967	SCHEME_V->interactive_repl = 0;
…		…
6064	SCHEME_V->interactive_repl = old_repl;	5974	SCHEME_V->interactive_repl = old_repl;
6065	restore_from_C_call (SCHEME_A);	5975	restore_from_C_call (SCHEME_A);
6066	return SCHEME_V->value;	5976	return SCHEME_V->value;
6067	}	5977	}
6068		5978
6069	pointer	5979	ecb_cold pointer
6070	scheme_eval (SCHEME_P_ pointer obj)	5980	scheme_eval (SCHEME_P_ pointer obj)
6071	{	5981	{
6072	int old_repl = SCHEME_V->interactive_repl;	5982	int old_repl = SCHEME_V->interactive_repl;
6073		5983
6074	SCHEME_V->interactive_repl = 0;	5984	SCHEME_V->interactive_repl = 0;
…		…
6086		5996
6087	/* ========== Main ========== */	5997	/* ========== Main ========== */
6088		5998
6089	#if STANDALONE	5999	#if STANDALONE
6090		6000
6091	int	6001	ecb_cold int
6092	main (int argc, char **argv)	6002	main (int argc, char **argv)
6093	{	6003	{
6094	# if USE_MULTIPLICITY	6004	# if USE_MULTIPLICITY
6095	scheme ssc;	6005	scheme ssc;
6096	scheme *const SCHEME_V = &ssc;	6006	scheme *const SCHEME_V = &ssc;
…		…
6098	# endif	6008	# endif
6099	int fin;	6009	int fin;
6100	char *file_name = InitFile;	6010	char *file_name = InitFile;
6101	int retcode;	6011	int retcode;
6102	int isfile = 1;	6012	int isfile = 1;
		6013	system ("ps v $PPID");//D
6103		6014
6104	if (argc == 2 && strcmp (argv[1], "-?") == 0)	6015	if (argc == 2 && strcmp (argv[1], "-?") == 0)
6105	{	6016	{
6106	xwrstr ("Usage: tinyscheme -?\n");	6017	putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6107	xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");	6018	putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6108	xwrstr ("followed by\n");	6019	putstr (SCHEME_A_ "followed by\n");
6109	xwrstr (" -1 <file> [<arg1> <arg2> ...]\n");	6020	putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6110	xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n");	6021	putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6111	xwrstr ("assuming that the executable is named tinyscheme.\n");	6022	putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6112	xwrstr ("Use - as filename for stdin.\n");	6023	putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6113	return 1;	6024	return 1;
6114	}	6025	}
6115		6026
6116	if (!scheme_init (SCHEME_A))	6027	if (!scheme_init (SCHEME_A))
6117	{	6028	{
6118	xwrstr ("Could not initialize!\n");	6029	putstr (SCHEME_A_ "Could not initialize!\n");
6119	return 2;	6030	return 2;
6120	}	6031	}
6121		6032
6122	# if USE_PORTS	6033	# if USE_PORTS
6123	scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);	6034	scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
…		…
6168	fin = open (file_name, O_RDONLY);	6079	fin = open (file_name, O_RDONLY);
6169	#endif	6080	#endif
6170		6081
6171	if (isfile && fin < 0)	6082	if (isfile && fin < 0)
6172	{	6083	{
6173	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");
6174	}	6085	}
6175	else	6086	else
6176	{	6087	{
6177	if (isfile)	6088	if (isfile)
6178	scheme_load_named_file (SCHEME_A_ fin, file_name);	6089	scheme_load_named_file (SCHEME_A_ fin, file_name);
…		…
6182	#if USE_PORTS	6093	#if USE_PORTS
6183	if (!isfile || fin != STDIN_FILENO)	6094	if (!isfile || fin != STDIN_FILENO)
6184	{	6095	{
6185	if (SCHEME_V->retcode != 0)	6096	if (SCHEME_V->retcode != 0)
6186	{	6097	{
6187	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");
6188	}	6099	}
6189		6100
6190	if (isfile)	6101	if (isfile)
6191	close (fin);	6102	close (fin);
6192	}	6103	}

Diff Legend

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