ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/cvsroot/microscheme/scheme.c

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

Diff Legend

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