ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/cvsroot/microscheme/scheme.c

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.50 by root, Tue Dec 1 00:47:54 2015 UTC vs.
Revision 1.69 by root, Mon Dec 7 22:12:53 2015 UTC

…		…
16	* (MINISCM) This is a revised and modified version by Akira KIDA.	16	* (MINISCM) This is a revised and modified version by Akira KIDA.
17	* (MINISCM) current version is 0.85k4 (15 May 1994)	17	* (MINISCM) current version is 0.85k4 (15 May 1994)
18	*	18	*
19	*/	19	*/
20		20
21	#define EXPERIMENT 1	21	#define _POSIX_C_SOURCE 200201
22		22	#define _XOPEN_SOURCE 600
23	#define PAGE_SIZE 4096 /* does not work on sparc/alpha */	23	#define _GNU_SOURCE 1 /* for malloc mremap */
24	#include "malloc.c"
25		24
26	#define SCHEME_SOURCE	25	#define SCHEME_SOURCE
27	#include "scheme-private.h"	26	#include "scheme-private.h"
28	#ifndef WIN32	27	#ifndef WIN32
29	# include <unistd.h>	28	# include <unistd.h>
30	#endif	29	#endif
31	#if USE_MATH	30	#if USE_MATH
32	# include <math.h>	31	# include <math.h>
33	#endif	32	#endif
34		33
		34	#define ECB_NO_THREADS 1
35	#include "ecb.h"	35	#include "ecb.h"
36		36
37	#include <sys/types.h>	37	#include <sys/types.h>
38	#include <sys/stat.h>	38	#include <sys/stat.h>
39	#include <fcntl.h>	39	#include <fcntl.h>
…		…
47	#include <string.h>	47	#include <string.h>
48		48
49	#include <limits.h>	49	#include <limits.h>
50	#include <inttypes.h>	50	#include <inttypes.h>
51	#include <float.h>	51	#include <float.h>
52	//#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
53		60
54	#if '1' != '0' + 1 \	61	#if '1' != '0' + 1 \
55	|| '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \	62	|| '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
56	|| '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \	63	|| '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
57	|| 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \	64	|| 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
…		…
79		86
80	#define BACKQUOTE '`'	87	#define BACKQUOTE '`'
81	#define WHITESPACE " \t\r\n\v\f"	88	#define WHITESPACE " \t\r\n\v\f"
82	#define DELIMITERS "()\";" WHITESPACE	89	#define DELIMITERS "()\";" WHITESPACE
83		90
84	#define NIL (&SCHEME_V->xNIL)	91	#define NIL POINTER (&SCHEME_V->xNIL)
85	#define S_T (&SCHEME_V->xT)	92	#define S_T POINTER (&SCHEME_V->xT)
86	#define S_F (&SCHEME_V->xF)	93	#define S_F POINTER (&SCHEME_V->xF)
87	#define S_SINK (&SCHEME_V->xsink)	94	#define S_SINK POINTER (&SCHEME_V->xsink)
88	#define S_EOF (&SCHEME_V->xEOF_OBJ)	95	#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
89		96
90	#if !USE_MULTIPLICITY	97	#if !USE_MULTIPLICITY
91	static scheme sc;	98	static scheme sc;
92	#endif	99	#endif
93		100
94	static void	101	ecb_cold static void
95	xbase (char *s, long n, int base)	102	xbase (char *s, long n, int base)
96	{	103	{
97	if (n < 0)	104	if (n < 0)
98	{	105	{
99	*s++ = '-';	106	*s++ = '-';
…		…
101	}	108	}
102		109
103	char *p = s;	110	char *p = s;
104		111
105	do {	112	do {
106	*p++ = '0' + n % base;	113	*p++ = "0123456789abcdef"[n % base];
107	n /= base;	114	n /= base;
108	} while (n);	115	} while (n);
109		116
110	*p-- = 0;	117	*p-- = 0;
111		118
…		…
114	char x = *s; *s = *p; *p = x;	121	char x = *s; *s = *p; *p = x;
115	--p; ++s;	122	--p; ++s;
116	}	123	}
117	}	124	}
118		125
119	static void	126	ecb_cold static void
120	xnum (char *s, long n)	127	xnum (char *s, long n)
121	{	128	{
122	xbase (s, n, 10);	129	xbase (s, n, 10);
123	}	130	}
124		131
125	static void	132	ecb_cold static void
126	xwrstr (const char *s)	133	putnum (SCHEME_P_ long n)
127	{
128	write (1, s, strlen (s));
129	}
130
131	static void
132	xwrnum (long n)
133	{	134	{
134	char buf[64];	135	char buf[64];
135		136
136	xnum (buf, n);	137	xnum (buf, n);
137	xwrstr (buf);	138	putstr (SCHEME_A_ buf);
138	}	139	}
		140
		141	#if USE_CHAR_CLASSIFIERS
		142	#include <ctype.h>
		143	#else
139		144
140	static char	145	static char
141	xtoupper (char c)	146	xtoupper (char c)
142	{	147	{
143	if (c >= 'a' && c <= 'z')	148	if (c >= 'a' && c <= 'z')
…		…
163		168
164	#define toupper(c) xtoupper (c)	169	#define toupper(c) xtoupper (c)
165	#define tolower(c) xtolower (c)	170	#define tolower(c) xtolower (c)
166	#define isdigit(c) xisdigit (c)	171	#define isdigit(c) xisdigit (c)
167		172
		173	#endif
		174
168	#if USE_IGNORECASE	175	#if USE_IGNORECASE
169	static const char *	176	ecb_cold static const char *
170	xstrlwr (char *s)	177	xstrlwr (char *s)
171	{	178	{
172	const char *p = s;	179	const char *p = s;
173		180
174	while (*s)	181	while (*s)
…		…
187	# define stricmp(a,b) strcmp (a, b)	194	# define stricmp(a,b) strcmp (a, b)
188	# define strlwr(s) (s)	195	# define strlwr(s) (s)
189	#endif	196	#endif
190		197
191	#ifndef prompt	198	#ifndef prompt
192	# define prompt "ts> "	199	# define prompt "ms> "
193	#endif	200	#endif
194		201
195	#ifndef InitFile	202	#ifndef InitFile
196	# define InitFile "init.scm"	203	# define InitFile "init.scm"
197	#endif	204	#endif
198		205
199	#ifndef FIRST_CELLSEGS
200	# define FIRST_CELLSEGS 3
201	#endif
202
203	enum scheme_types	206	enum scheme_types
204	{	207	{
205	T_INTEGER,	208	T_INTEGER,
		209	T_CHARACTER,
206	T_REAL,	210	T_REAL,
207	T_STRING,	211	T_STRING,
208	T_SYMBOL,	212	T_SYMBOL,
209	T_PROC,	213	T_PROC,
210	T_PAIR, /* also used for free cells */	214	T_PAIR, /* also used for free cells */
211	T_CLOSURE,	215	T_CLOSURE,
		216	T_BYTECODE, // temp
		217	T_MACRO,
212	T_CONTINUATION,	218	T_CONTINUATION,
213	T_FOREIGN,	219	T_FOREIGN,
214	T_CHARACTER,
215	T_PORT,	220	T_PORT,
216	T_VECTOR,	221	T_VECTOR,
217	T_MACRO,
218	T_PROMISE,	222	T_PROMISE,
219	T_ENVIRONMENT,	223	T_ENVIRONMENT,
220	/* one more... */	224	T_SPECIAL, // #t, #f, '(), eof-object
		225
221	T_NUM_SYSTEM_TYPES	226	T_NUM_SYSTEM_TYPES
222	};	227	};
223		228
224	#define T_MASKTYPE 0x000f	229	#define T_MASKTYPE 0x001f
225	#define T_SYNTAX 0x0010	230	#define T_SYNTAX 0x0020
226	#define T_IMMUTABLE 0x0020	231	#define T_IMMUTABLE 0x0040
227	#define T_ATOM 0x0040 /* only for gc */	232	#define T_ATOM 0x0080 /* only for gc */
228	#define T_MARK 0x0080 /* only for gc */	233	//#define T_MARK 0x0080 /* only for gc */
229		234
230	/* num, for generic arithmetic */	235	/* num, for generic arithmetic */
231	struct num	236	struct num
232	{	237	{
233	IVALUE ivalue;	238	IVALUE ivalue;
…		…
258	static num num_op (enum num_op op, num a, num b);	263	static num num_op (enum num_op op, num a, num b);
259	static num num_intdiv (num a, num b);	264	static num num_intdiv (num a, num b);
260	static num num_rem (num a, num b);	265	static num num_rem (num a, num b);
261	static num num_mod (num a, num b);	266	static num num_mod (num a, num b);
262		267
263	#if USE_MATH
264	static double round_per_R5RS (double x);
265	#endif
266	static int is_zero_rvalue (RVALUE x);	268	static int is_zero_rvalue (RVALUE x);
267		269
268	static num num_zero;	270	static num num_zero;
269	static num num_one;	271	static num num_one;
270		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
271	/* macros for cell operations */	277	/* macros for cell operations */
272	#define typeflag(p) ((p)->flag + 0)	278	#define typeflag(p) (CELL(p)->flag + 0)
273	#define set_typeflag(p,v) ((p)->flag = (v))	279	#define set_typeflag(p,v) (CELL(p)->flag = (v))
274	#define type(p) (typeflag (p) & T_MASKTYPE)	280	#define type(p) (typeflag (p) & T_MASKTYPE)
275		281
276	INTERFACE int	282	INTERFACE int
277	is_string (pointer p)	283	is_string (pointer p)
278	{	284	{
279	return type (p) == T_STRING;	285	return type (p) == T_STRING;
280	}	286	}
281		287
282	#define strvalue(p) ((p)->object.string.svalue)	288	#define strvalue(p) (CELL(p)->object.string.svalue)
283	#define strlength(p) ((p)->object.string.length)	289	#define strlength(p) (CELL(p)->object.string.length)
284		290
285	INTERFACE int	291	INTERFACE int
286	is_vector (pointer p)	292	is_vector (pointer p)
287	{	293	{
288	return type (p) == T_VECTOR;	294	return type (p) == T_VECTOR;
289	}	295	}
290		296
291	#define vecvalue(p) ((p)->object.vector.vvalue)	297	#define vecvalue(p) (CELL(p)->object.vector.vvalue)
292	#define veclength(p) ((p)->object.vector.length)	298	#define veclength(p) (CELL(p)->object.vector.length)
293	INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);	299	INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
294	INTERFACE pointer vector_get (pointer vec, uint32_t ielem);	300	INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
295	INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);	301	INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
296		302
297	INTERFACE int	303	INTERFACE int
…		…
323	string_value (pointer p)	329	string_value (pointer p)
324	{	330	{
325	return strvalue (p);	331	return strvalue (p);
326	}	332	}
327		333
328	#define ivalue_unchecked(p) (p)->object.ivalue	334	#define ivalue_unchecked(p) (CELL(p)->object.ivalue + 0)
329	#define set_ivalue(p,v) (p)->object.ivalue = (v)	335	#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
330		336
331	#if USE_REAL	337	#if USE_REAL
332	#define rvalue_unchecked(p) (p)->object.rvalue	338	#define rvalue_unchecked(p) CELL(p)->object.rvalue
333	#define set_rvalue(p,v) (p)->object.rvalue = (v)	339	#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
334	#else	340	#else
335	#define rvalue_unchecked(p) (p)->object.ivalue	341	#define rvalue_unchecked(p) CELL(p)->object.ivalue
336	#define set_rvalue(p,v) (p)->object.ivalue = (v)	342	#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
337	#endif	343	#endif
338		344
339	INTERFACE long	345	INTERFACE long
340	charvalue (pointer p)	346	charvalue (pointer p)
341	{	347	{
342	return ivalue_unchecked (p);	348	return ivalue_unchecked (p);
343	}	349	}
344		350
		351	#define port(p) CELL(p)->object.port
		352	#define set_port(p,v) port(p) = (v)
345	INTERFACE int	353	INTERFACE int
346	is_port (pointer p)	354	is_port (pointer p)
347	{	355	{
348	return type (p) == T_PORT;	356	return type (p) == T_PORT;
349	}	357	}
350		358
351	INTERFACE int	359	INTERFACE int
352	is_inport (pointer p)	360	is_inport (pointer p)
353	{	361	{
354	return is_port (p) && p->object.port->kind & port_input;	362	return is_port (p) && port (p)->kind & port_input;
355	}	363	}
356		364
357	INTERFACE int	365	INTERFACE int
358	is_outport (pointer p)	366	is_outport (pointer p)
359	{	367	{
360	return is_port (p) && p->object.port->kind & port_output;	368	return is_port (p) && port (p)->kind & port_output;
361	}	369	}
362		370
363	INTERFACE int	371	INTERFACE int
364	is_pair (pointer p)	372	is_pair (pointer p)
365	{	373	{
366	return type (p) == T_PAIR;	374	return type (p) == T_PAIR;
367	}	375	}
368		376
369	#define car(p) ((p)->object.cons.car + 0)	377	#define car(p) (POINTER (CELL(p)->object.cons.car))
370	#define cdr(p) ((p)->object.cons.cdr + 0)	378	#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
371		379
372	static pointer caar (pointer p) { return car (car (p)); }	380	static pointer caar (pointer p) { return car (car (p)); }
373	static pointer cadr (pointer p) { return car (cdr (p)); }	381	static pointer cadr (pointer p) { return car (cdr (p)); }
374	static pointer cdar (pointer p) { return cdr (car (p)); }	382	static pointer cdar (pointer p) { return cdr (car (p)); }
375	static pointer cddr (pointer p) { return cdr (cdr (p)); }	383	static pointer cddr (pointer p) { return cdr (cdr (p)); }
376		384
377	static pointer cadar (pointer p) { return car (cdr (car (p))); }	385	static pointer cadar (pointer p) { return car (cdr (car (p))); }
378	static pointer caddr (pointer p) { return car (cdr (cdr (p))); }	386	static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
379	static pointer cdaar (pointer p) { return cdr (car (car (p))); }	387	static pointer cdaar (pointer p) { return cdr (car (car (p))); }
380		388
		389	static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); }
		390
381	INTERFACE void	391	INTERFACE void
382	set_car (pointer p, pointer q)	392	set_car (pointer p, pointer q)
383	{	393	{
384	p->object.cons.car = q;	394	CELL(p)->object.cons.car = CELL (q);
385	}	395	}
386		396
387	INTERFACE void	397	INTERFACE void
388	set_cdr (pointer p, pointer q)	398	set_cdr (pointer p, pointer q)
389	{	399	{
390	p->object.cons.cdr = q;	400	CELL(p)->object.cons.cdr = CELL (q);
391	}	401	}
392		402
393	INTERFACE pointer	403	INTERFACE pointer
394	pair_car (pointer p)	404	pair_car (pointer p)
395	{	405	{
…		…
501		511
502	#define is_atom(p) (typeflag (p) & T_ATOM)	512	#define is_atom(p) (typeflag (p) & T_ATOM)
503	#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)	513	#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
504	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)	514	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
505		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
506	#define is_mark(p) (typeflag (p) & T_MARK)	521	#define is_mark(p) (typeflag (p) & T_MARK)
507	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)	522	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
508	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	523	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
		524	#endif
509		525
510	INTERFACE int	526	INTERFACE int
511	is_immutable (pointer p)	527	is_immutable (pointer p)
512	{	528	{
513	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	529	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
…		…
525	proper list: length	541	proper list: length
526	circular list: -1	542	circular list: -1
527	not even a pair: -2	543	not even a pair: -2
528	dotted list: -2 minus length before dot	544	dotted list: -2 minus length before dot
529	*/	545	*/
530	INTERFACE int	546	ecb_hot INTERFACE int
531	list_length (SCHEME_P_ pointer a)	547	list_length (SCHEME_P_ pointer a)
532	{	548	{
533	int i = 0;	549	int i = 0;
534	pointer slow, fast;	550	pointer slow, fast;
535		551
…		…
574	{	590	{
575	return list_length (SCHEME_A_ a) >= 0;	591	return list_length (SCHEME_A_ a) >= 0;
576	}	592	}
577		593
578	#if USE_CHAR_CLASSIFIERS	594	#if USE_CHAR_CLASSIFIERS
		595
579	ecb_inline int	596	ecb_inline int
580	Cisalpha (int c)	597	Cisalpha (int c)
581	{	598	{
582	return isascii (c) && isalpha (c);	599	return isascii (c) && isalpha (c);
583	}	600	}
…		…
641	"gs",	658	"gs",
642	"rs",	659	"rs",
643	"us"	660	"us"
644	};	661	};
645		662
646	static int	663	ecb_cold static int
647	is_ascii_name (const char *name, int *pc)	664	is_ascii_name (const char *name, int *pc)
648	{	665	{
649	int i;	666	int i;
650		667
651	for (i = 0; i < 32; i++)	668	for (i = 0; i < 32; i++)
…		…
670		687
671	static int file_push (SCHEME_P_ const char *fname);	688	static int file_push (SCHEME_P_ const char *fname);
672	static void file_pop (SCHEME_P);	689	static void file_pop (SCHEME_P);
673	static int file_interactive (SCHEME_P);	690	static int file_interactive (SCHEME_P);
674	ecb_inline int is_one_of (const char *s, int c);	691	ecb_inline int is_one_of (const char *s, int c);
675	static int alloc_cellseg (SCHEME_P_ int n);	692	static int alloc_cellseg (SCHEME_P);
676	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);	693	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
677	static void finalize_cell (SCHEME_P_ pointer a);	694	static void finalize_cell (SCHEME_P_ pointer a);
678	static int count_consecutive_cells (pointer x, int needed);
679	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);
680	static pointer mk_number (SCHEME_P_ const num n);	696	static pointer mk_number (SCHEME_P_ const num n);
681	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);
682	static pointer mk_vector (SCHEME_P_ uint32_t len);	698	static pointer mk_vector (SCHEME_P_ uint32_t len);
683	static pointer mk_atom (SCHEME_P_ char *q);	699	static pointer mk_atom (SCHEME_P_ char *q);
684	static pointer mk_sharp_const (SCHEME_P_ char *name);	700	static pointer mk_sharp_const (SCHEME_P_ char *name);
685		701
		702	static pointer mk_port (SCHEME_P_ port *p);
		703
686	#if USE_PORTS	704	#if USE_PORTS
687	static pointer mk_port (SCHEME_P_ port *p);
688	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);
689	static pointer port_from_file (SCHEME_P_ int, int prop);	706	static pointer port_from_file (SCHEME_P_ int, int prop);
690	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);
691	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);
692	static port *port_rep_from_file (SCHEME_P_ int, int prop);	709	static port *port_rep_from_file (SCHEME_P_ int, int prop);
693	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);
694	static void port_close (SCHEME_P_ pointer p, int flag);	711	static void port_close (SCHEME_P_ pointer p, int flag);
695	#endif	712	#endif
		713
696	static void mark (pointer a);	714	static void mark (pointer a);
697	static void gc (SCHEME_P_ pointer a, pointer b);	715	static void gc (SCHEME_P_ pointer a, pointer b);
698	static int basic_inchar (port *pt);	716	static int basic_inchar (port *pt);
699	static int inchar (SCHEME_P);	717	static int inchar (SCHEME_P);
700	static void backchar (SCHEME_P_ int c);	718	static void backchar (SCHEME_P_ int c);
701	static char *readstr_upto (SCHEME_P_ int skip, const char *delim);	719	static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
702	static pointer readstrexp (SCHEME_P_ char delim);	720	static pointer readstrexp (SCHEME_P_ char delim);
703	ecb_inline int skipspace (SCHEME_P);	721	static int skipspace (SCHEME_P);
704	static int token (SCHEME_P);	722	static int token (SCHEME_P);
705	static void printslashstring (SCHEME_P_ char *s, int len);	723	static void printslashstring (SCHEME_P_ char *s, int len);
706	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);
707	static void printatom (SCHEME_P_ pointer l, int f);	725	static void printatom (SCHEME_P_ pointer l, int f);
708	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	726	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
874	}	892	}
875		893
876	return ret;	894	return ret;
877	}	895	}
878		896
879	#if USE_MATH
880
881	/* Round to nearest. Round to even if midway */
882	static double
883	round_per_R5RS (double x)
884	{
885	double fl = floor (x);
886	double ce = ceil (x);
887	double dfl = x - fl;
888	double dce = ce - x;
889
890	if (dfl > dce)
891	return ce;
892	else if (dfl < dce)
893	return fl;
894	else
895	{
896	if (fmod (fl, 2) == 0) /* I imagine this holds */
897	return fl;
898	else
899	return ce;
900	}
901	}
902	#endif
903
904	static int	897	static int
905	is_zero_rvalue (RVALUE x)	898	is_zero_rvalue (RVALUE x)
906	{	899	{
907	return x == 0;	900	return x == 0;
908	#if 0	901	#if 0
…		…
913	#endif	906	#endif
914	#endif	907	#endif
915	}	908	}
916		909
917	/* allocate new cell segment */	910	/* allocate new cell segment */
918	static int	911	ecb_cold static int
919	alloc_cellseg (SCHEME_P_ int n)	912	alloc_cellseg (SCHEME_P)
920	{	913	{
921	pointer newp;	914	struct cell *newp;
922	pointer last;	915	struct cell *last;
923	pointer p;	916	struct cell *p;
924	char *cp;	917	char *cp;
925	long i;	918	long i;
926	int k;	919	int k;
927		920
928	static int segsize = CELL_SEGSIZE >> 1;	921	static int segsize = CELL_SEGSIZE >> 1;
929	segsize <<= 1;	922	segsize <<= 1;
930		923
931	for (k = 0; k < n; k++)
932	{
933	if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
934	return k;
935
936	cp = malloc (segsize * sizeof (struct cell));	924	cp = malloc (segsize * sizeof (struct cell));
937		925
938	if (!cp && USE_ERROR_CHECKING)	926	if (!cp && USE_ERROR_CHECKING)
939	return k;	927	return k;
940		928
941	i = ++SCHEME_V->last_cell_seg;	929	i = ++SCHEME_V->last_cell_seg;
942	SCHEME_V->alloc_seg[i] = cp;
943		930
944	newp = (pointer)cp;	931	newp = (struct cell *)cp;
945	SCHEME_V->cell_seg[i] = newp;	932	SCHEME_V->cell_seg[i] = newp;
946	SCHEME_V->cell_segsize[i] = segsize;	933	SCHEME_V->cell_segsize[i] = segsize;
947	SCHEME_V->fcells += segsize;	934	SCHEME_V->fcells += segsize;
948	last = newp + segsize - 1;	935	last = newp + segsize - 1;
949		936
950	for (p = newp; p <= last; p++)	937	for (p = newp; p <= last; p++)
951	{	938	{
		939	pointer cp = POINTER (p);
		940	clrmark (cp);
952	set_typeflag (p, T_PAIR);	941	set_typeflag (cp, T_PAIR);
953	set_car (p, NIL);	942	set_car (cp, NIL);
954	set_cdr (p, p + 1);	943	set_cdr (cp, POINTER (p + 1));
955	}	944	}
956		945
957	set_cdr (last, SCHEME_V->free_cell);	946	set_cdr (POINTER (last), SCHEME_V->free_cell);
958	SCHEME_V->free_cell = newp;	947	SCHEME_V->free_cell = POINTER (newp);
959	}
960		948
961	return n;	949	return 1;
962	}	950	}
963		951
964	/* get new cell. parameter a, b is marked by gc. */	952	/* get new cell. parameter a, b is marked by gc. */
965	ecb_inline pointer	953	ecb_inline pointer
966	get_cell_x (SCHEME_P_ pointer a, pointer b)	954	get_cell_x (SCHEME_P_ pointer a, pointer b)
…		…
970	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	958	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
971	return S_SINK;	959	return S_SINK;
972		960
973	if (SCHEME_V->free_cell == NIL)	961	if (SCHEME_V->free_cell == NIL)
974	{	962	{
975	const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1;	963	const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
976		964
977	gc (SCHEME_A_ a, b);	965	gc (SCHEME_A_ a, b);
978		966
979	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)
980	{	968	{
981	/* 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 */
982	if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL)	970	if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
983	{	971	{
984	#if USE_ERROR_CHECKING	972	#if USE_ERROR_CHECKING
985	SCHEME_V->no_memory = 1;	973	SCHEME_V->no_memory = 1;
986	return S_SINK;	974	return S_SINK;
987	#endif	975	#endif
…		…
999	}	987	}
1000	}	988	}
1001		989
1002	/* To retain recent allocs before interpreter knows about them -	990	/* To retain recent allocs before interpreter knows about them -
1003	Tehom */	991	Tehom */
1004		992	ecb_hot static void
1005	static void
1006	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)	993	push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1007	{	994	{
1008	pointer holder = get_cell_x (SCHEME_A_ recent, extra);	995	pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1009		996
1010	set_typeflag (holder, T_PAIR);	997	set_typeflag (holder, T_PAIR);
…		…
1012	set_car (holder, recent);	999	set_car (holder, recent);
1013	set_cdr (holder, car (S_SINK));	1000	set_cdr (holder, car (S_SINK));
1014	set_car (S_SINK, holder);	1001	set_car (S_SINK, holder);
1015	}	1002	}
1016		1003
1017	static pointer	1004	ecb_hot static pointer
1018	get_cell (SCHEME_P_ pointer a, pointer b)	1005	get_cell (SCHEME_P_ pointer a, pointer b)
1019	{	1006	{
1020	pointer cell = get_cell_x (SCHEME_A_ a, b);	1007	pointer cell = get_cell_x (SCHEME_A_ a, b);
1021		1008
1022	/* 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
…		…
1040	return S_SINK;	1027	return S_SINK;
1041		1028
1042	/* Record it as a vector so that gc understands it. */	1029	/* Record it as a vector so that gc understands it. */
1043	set_typeflag (v, T_VECTOR | T_ATOM);	1030	set_typeflag (v, T_VECTOR | T_ATOM);
1044		1031
1045	v->object.vector.vvalue = e;	1032	CELL(v)->object.vector.vvalue = e;
1046	v->object.vector.length = len;	1033	CELL(v)->object.vector.length = len;
1047	fill_vector (v, 0, init);	1034	fill_vector (v, 0, init);
1048	push_recent_alloc (SCHEME_A_ v, NIL);	1035	push_recent_alloc (SCHEME_A_ v, NIL);
1049		1036
1050	return v;	1037	return v;
1051	}	1038	}
…		…
1060	static void	1047	static void
1061	check_cell_alloced (pointer p, int expect_alloced)	1048	check_cell_alloced (pointer p, int expect_alloced)
1062	{	1049	{
1063	/* 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. */
1064	if (typeflag (p) & !expect_alloced)	1051	if (typeflag (p) & !expect_alloced)
1065	xwrstr ("Cell is already allocated!\n");	1052	putstr (SCHEME_A_ "Cell is already allocated!\n");
1066		1053
1067	if (!(typeflag (p)) & expect_alloced)	1054	if (!(typeflag (p)) & expect_alloced)
1068	xwrstr ("Cell is not allocated!\n");	1055	putstr (SCHEME_A_ "Cell is not allocated!\n");
1069	}	1056	}
1070		1057
1071	static void	1058	static void
1072	check_range_alloced (pointer p, int n, int expect_alloced)	1059	check_range_alloced (pointer p, int n, int expect_alloced)
1073	{	1060	{
…		…
1079	#endif	1066	#endif
1080		1067
1081	/* Medium level cell allocation */	1068	/* Medium level cell allocation */
1082		1069
1083	/* get new cons cell */	1070	/* get new cons cell */
1084	pointer	1071	ecb_hot static pointer
1085	xcons (SCHEME_P_ pointer a, pointer b, int immutable)	1072	xcons (SCHEME_P_ pointer a, pointer b)
1086	{	1073	{
1087	pointer x = get_cell (SCHEME_A_ a, b);	1074	pointer x = get_cell (SCHEME_A_ a, b);
1088		1075
1089	set_typeflag (x, T_PAIR);	1076	set_typeflag (x, T_PAIR);
1090
1091	if (immutable)
1092	setimmutable (x);
1093		1077
1094	set_car (x, a);	1078	set_car (x, a);
1095	set_cdr (x, b);	1079	set_cdr (x, b);
1096		1080
1097	return x;	1081	return x;
1098	}	1082	}
1099		1083
1100	static pointer	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
1101	generate_symbol (SCHEME_P_ const char *name)	1096	generate_symbol (SCHEME_P_ const char *name)
1102	{	1097	{
1103	pointer x = mk_string (SCHEME_A_ name);	1098	pointer x = mk_string (SCHEME_A_ name);
1104	setimmutable (x);	1099	setimmutable (x);
1105	set_typeflag (x, T_SYMBOL | T_ATOM);	1100	set_typeflag (x, T_SYMBOL | T_ATOM);
…		…
1111	#ifndef USE_OBJECT_LIST	1106	#ifndef USE_OBJECT_LIST
1112		1107
1113	static int	1108	static int
1114	hash_fn (const char *key, int table_size)	1109	hash_fn (const char *key, int table_size)
1115	{	1110	{
1116	const unsigned char *p = key;	1111	const unsigned char *p = (unsigned char *)key;
1117	uint32_t hash = 2166136261;	1112	uint32_t hash = 2166136261U;
1118		1113
1119	while (*p)	1114	while (*p)
1120	hash = (hash ^ *p++) * 16777619;	1115	hash = (hash ^ *p++) * 16777619;
1121		1116
1122	return hash % table_size;	1117	return hash % table_size;
1123	}	1118	}
1124		1119
1125	static pointer	1120	ecb_cold static pointer
1126	oblist_initial_value (SCHEME_P)	1121	oblist_initial_value (SCHEME_P)
1127	{	1122	{
1128	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */	1123	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1129	}	1124	}
1130		1125
1131	/* returns the new symbol */	1126	/* returns the new symbol */
1132	static pointer	1127	ecb_cold static pointer
1133	oblist_add_by_name (SCHEME_P_ const char *name)	1128	oblist_add_by_name (SCHEME_P_ const char *name)
1134	{	1129	{
1135	pointer x = generate_symbol (SCHEME_A_ name);	1130	pointer x = generate_symbol (SCHEME_A_ name);
1136	int location = hash_fn (name, veclength (SCHEME_V->oblist));	1131	int location = hash_fn (name, veclength (SCHEME_V->oblist));
1137	vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));	1132	vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1138	return x;	1133	return x;
1139	}	1134	}
1140		1135
1141	ecb_inline pointer	1136	ecb_cold static pointer
1142	oblist_find_by_name (SCHEME_P_ const char *name)	1137	oblist_find_by_name (SCHEME_P_ const char *name)
1143	{	1138	{
1144	int location;	1139	int location;
1145	pointer x;	1140	pointer x;
1146	char *s;	1141	char *s;
…		…
1157	}	1152	}
1158		1153
1159	return NIL;	1154	return NIL;
1160	}	1155	}
1161		1156
1162	static pointer	1157	ecb_cold static pointer
1163	oblist_all_symbols (SCHEME_P)	1158	oblist_all_symbols (SCHEME_P)
1164	{	1159	{
1165	int i;	1160	int i;
1166	pointer x;	1161	pointer x;
1167	pointer ob_list = NIL;	1162	pointer ob_list = NIL;
…		…
1173	return ob_list;	1168	return ob_list;
1174	}	1169	}
1175		1170
1176	#else	1171	#else
1177		1172
1178	static pointer	1173	ecb_cold static pointer
1179	oblist_initial_value (SCHEME_P)	1174	oblist_initial_value (SCHEME_P)
1180	{	1175	{
1181	return NIL;	1176	return NIL;
1182	}	1177	}
1183		1178
1184	ecb_inline pointer	1179	ecb_cold static pointer
1185	oblist_find_by_name (SCHEME_P_ const char *name)	1180	oblist_find_by_name (SCHEME_P_ const char *name)
1186	{	1181	{
1187	pointer x;	1182	pointer x;
1188	char *s;	1183	char *s;
1189		1184
…		…
1198		1193
1199	return NIL;	1194	return NIL;
1200	}	1195	}
1201		1196
1202	/* returns the new symbol */	1197	/* returns the new symbol */
1203	static pointer	1198	ecb_cold static pointer
1204	oblist_add_by_name (SCHEME_P_ const char *name)	1199	oblist_add_by_name (SCHEME_P_ const char *name)
1205	{	1200	{
1206	pointer x = generate_symbol (SCHEME_A_ name);	1201	pointer x = generate_symbol (SCHEME_A_ name);
1207	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);	1202	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1208	return x;	1203	return x;
1209	}	1204	}
1210		1205
1211	static pointer	1206	ecb_cold static pointer
1212	oblist_all_symbols (SCHEME_P)	1207	oblist_all_symbols (SCHEME_P)
1213	{	1208	{
1214	return SCHEME_V->oblist;	1209	return SCHEME_V->oblist;
1215	}	1210	}
1216		1211
1217	#endif	1212	#endif
1218		1213
1219	#if USE_PORTS
1220	static pointer	1214	ecb_cold static pointer
1221	mk_port (SCHEME_P_ port *p)	1215	mk_port (SCHEME_P_ port *p)
1222	{	1216	{
1223	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1217	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1224		1218
1225	set_typeflag (x, T_PORT | T_ATOM);	1219	set_typeflag (x, T_PORT | T_ATOM);
1226	x->object.port = p;	1220	set_port (x, p);
1227		1221
1228	return x;	1222	return x;
1229	}	1223	}
1230	#endif
1231		1224
1232	pointer	1225	ecb_cold pointer
1233	mk_foreign_func (SCHEME_P_ foreign_func f)	1226	mk_foreign_func (SCHEME_P_ foreign_func f)
1234	{	1227	{
1235	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1228	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1236		1229
1237	set_typeflag (x, T_FOREIGN | T_ATOM);	1230	set_typeflag (x, T_FOREIGN | T_ATOM);
1238	x->object.ff = f;	1231	CELL(x)->object.ff = f;
1239		1232
1240	return x;	1233	return x;
1241	}	1234	}
1242		1235
1243	INTERFACE pointer	1236	INTERFACE pointer
…		…
1266	if (!*pp)	1259	if (!*pp)
1267	{	1260	{
1268	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1261	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1269		1262
1270	set_typeflag (x, T_INTEGER | T_ATOM);	1263	set_typeflag (x, T_INTEGER | T_ATOM);
1271	setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */	1264	setimmutable (x); /* shouldn't do anything, doesn't cost anything */
1272	set_ivalue (x, n);	1265	set_ivalue (x, n);
1273		1266
1274	*pp = x;	1267	*pp = x;
1275	}	1268	}
1276		1269
…		…
1402	x = oblist_add_by_name (SCHEME_A_ name);	1395	x = oblist_add_by_name (SCHEME_A_ name);
1403		1396
1404	return x;	1397	return x;
1405	}	1398	}
1406		1399
1407	INTERFACE pointer	1400	ecb_cold INTERFACE pointer
1408	gensym (SCHEME_P)	1401	gensym (SCHEME_P)
1409	{	1402	{
1410	pointer x;	1403	pointer x;
1411	char name[40] = "gensym-";	1404	char name[40] = "gensym-";
1412	xnum (name + 7, ++SCHEME_V->gensym_cnt);	1405	xnum (name + 7, ++SCHEME_V->gensym_cnt);
…		…
1419	{	1412	{
1420	return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;	1413	return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1421	}	1414	}
1422		1415
1423	/* make symbol or number atom from string */	1416	/* make symbol or number atom from string */
1424	static pointer	1417	ecb_cold static pointer
1425	mk_atom (SCHEME_P_ char *q)	1418	mk_atom (SCHEME_P_ char *q)
1426	{	1419	{
1427	char c, *p;	1420	char c, *p;
1428	int has_dec_point = 0;	1421	int has_dec_point = 0;
1429	int has_fp_exp = 0;	1422	int has_fp_exp = 0;
…		…
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	if (!strcmp (name, "t"))	1501	if (!strcmp (name, "t"))
1509	return S_T;	1502	return S_T;
1510	else if (!strcmp (name, "f"))	1503	else if (!strcmp (name, "f"))
1511	return S_F;	1504	return S_F;
1512	else if (*name == '\\') /* #\w (character) */	1505	else if (*name == '\\') /* #\w (character) */
1513	{	1506	{
1514	int c;	1507	int c;
1515		1508
		1509	// TODO: optimise
1516	if (stricmp (name + 1, "space") == 0)	1510	if (stricmp (name + 1, "space") == 0)
1517	c = ' ';	1511	c = ' ';
1518	else if (stricmp (name + 1, "newline") == 0)	1512	else if (stricmp (name + 1, "newline") == 0)
1519	c = '\n';	1513	c = '\n';
1520	else if (stricmp (name + 1, "return") == 0)	1514	else if (stricmp (name + 1, "return") == 0)
1521	c = '\r';	1515	c = '\r';
1522	else if (stricmp (name + 1, "tab") == 0)	1516	else if (stricmp (name + 1, "tab") == 0)
1523	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;
1524	else if (name[1] == 'x' && name[2] != 0)	1528	else if (name[1] == 'x' && name[2] != 0)
1525	{	1529	{
1526	long c1 = strtol (name + 2, 0, 16);	1530	long c1 = strtol (name + 2, 0, 16);
1527		1531
1528	if (0 <= c1 && c1 <= UCHAR_MAX)	1532	if (0 <= c1 && c1 <= UCHAR_MAX)
…		…
1542	return mk_character (SCHEME_A_ c);	1546	return mk_character (SCHEME_A_ c);
1543	}	1547	}
1544	else	1548	else
1545	{	1549	{
1546	/* identify base by string index */	1550	/* identify base by string index */
1547	const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";	1551	const char baseidx[18] = "ffbf" "ffff" "ofdf" "ffff" "x";
1548	char *base = strchr (baseidx, *name);	1552	char *base = strchr (baseidx, *name);
1549		1553
1550	if (base)	1554	if (base && *base)
1551	return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));	1555	return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1552		1556
1553	return NIL;	1557	return NIL;
1554	}	1558	}
1555	}	1559	}
1556		1560
1557	/* ========== 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	}
1558		1581
1559	/*--	1582	/*--
1560	* 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,
1561	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,	1584	* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1562	* for marking.	1585	* for marking.
1563	*	1586	*
1564	* The exception is vectors - vectors are currently marked recursively,	1587	* The exception is vectors - vectors are currently marked recursively,
1565	* which is inherited form tinyscheme and could be fixed by having another	1588	* which is inherited form tinyscheme and could be fixed by having another
1566	* word of context in the vector	1589	* word of context in the vector
1567	*/	1590	*/
1568	static void	1591	ecb_hot static void
1569	mark (pointer a)	1592	mark (pointer a)
1570	{	1593	{
1571	pointer t, q, p;	1594	pointer t, q, p;
1572		1595
1573	t = 0;	1596	t = 0;
…		…
1630	p = q;	1653	p = q;
1631	goto E6;	1654	goto E6;
1632	}	1655	}
1633	}	1656	}
1634		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
1635	/* garbage collection. parameter a, b is marked. */	1700	/* garbage collection. parameter a, b is marked. */
1636	static void	1701	ecb_cold static void
1637	gc (SCHEME_P_ pointer a, pointer b)	1702	gc (SCHEME_P_ pointer a, pointer b)
1638	{	1703	{
1639	pointer p;
1640	int i;	1704	int i;
1641		1705
1642	if (SCHEME_V->gc_verbose)	1706	if (SCHEME_V->gc_verbose)
1643	putstr (SCHEME_A_ "gc...");	1707	putstr (SCHEME_A_ "gc...");
1644		1708
…		…
1677	clrmark (NIL);	1741	clrmark (NIL);
1678	SCHEME_V->fcells = 0;	1742	SCHEME_V->fcells = 0;
1679	SCHEME_V->free_cell = NIL;	1743	SCHEME_V->free_cell = NIL;
1680		1744
1681	if (SCHEME_V->gc_verbose)	1745	if (SCHEME_V->gc_verbose)
1682	xwrstr ("freeing...");	1746	putstr (SCHEME_A_ "freeing...");
1683		1747
1684	uint32_t total = 0;	1748	gc_free (SCHEME_A);
1685
1686	/* Here we scan the cells to build the free-list. */
1687	for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1688	{
1689	pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1690	total += SCHEME_V->cell_segsize [i];
1691
1692	for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1693	{
1694	if (is_mark (p))
1695	clrmark (p);
1696	else
1697	{
1698	/* reclaim cell */
1699	if (typeflag (p) != T_PAIR)
1700	{
1701	finalize_cell (SCHEME_A_ p);
1702	set_typeflag (p, T_PAIR);
1703	set_car (p, NIL);
1704	}
1705
1706	++SCHEME_V->fcells;
1707	set_cdr (p, SCHEME_V->free_cell);
1708	SCHEME_V->free_cell = p;
1709	}
1710	}
1711	}
1712
1713	if (SCHEME_V->gc_verbose)
1714	{
1715	xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n");
1716	}
1717	}
1718
1719	static void
1720	finalize_cell (SCHEME_P_ pointer a)
1721	{
1722	/* TODO, fast bitmap check? */
1723	if (is_string (a) || is_symbol (a))
1724	free (strvalue (a));
1725	else if (is_vector (a))
1726	free (vecvalue (a));
1727	#if USE_PORTS
1728	else if (is_port (a))
1729	{
1730	if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1731	port_close (SCHEME_A_ a, port_input | port_output);
1732
1733	free (a->object.port);
1734	}
1735	#endif
1736	}	1749	}
1737		1750
1738	/* ========== Routines for Reading ========== */	1751	/* ========== Routines for Reading ========== */
1739		1752
1740	static int	1753	ecb_cold static int
1741	file_push (SCHEME_P_ const char *fname)	1754	file_push (SCHEME_P_ const char *fname)
1742	{	1755	{
1743	#if USE_PORTS
1744	int fin;	1756	int fin;
1745		1757
1746	if (SCHEME_V->file_i == MAXFIL - 1)	1758	if (SCHEME_V->file_i == MAXFIL - 1)
1747	return 0;	1759	return 0;
1748		1760
…		…
1754	SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;	1766	SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1755	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;
1756	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;
1757	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;
1758	SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;	1770	SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1759	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);
1760		1772
1761	#if SHOW_ERROR_LINE	1773	#if SHOW_ERROR_LINE
1762	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;
1763		1775
1764	if (fname)	1776	if (fname)
1765	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);
1766	#endif	1778	#endif
1767	}	1779	}
1768		1780
1769	return fin >= 0;	1781	return fin >= 0;
1770
1771	#else
1772	return 1;
1773	#endif
1774	}	1782	}
1775		1783
1776	static void	1784	ecb_cold static void
1777	file_pop (SCHEME_P)	1785	file_pop (SCHEME_P)
1778	{	1786	{
1779	if (SCHEME_V->file_i != 0)	1787	if (SCHEME_V->file_i != 0)
1780	{	1788	{
1781	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];	1789	SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1782	#if USE_PORTS	1790	#if USE_PORTS
1783	port_close (SCHEME_A_ SCHEME_V->loadport, port_input);	1791	port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1784	#endif	1792	#endif
1785	SCHEME_V->file_i--;	1793	SCHEME_V->file_i--;
1786	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);
1787	}	1795	}
1788	}	1796	}
1789		1797
1790	static int	1798	ecb_cold static int
1791	file_interactive (SCHEME_P)	1799	file_interactive (SCHEME_P)
1792	{	1800	{
1793	#if USE_PORTS	1801	#if USE_PORTS
1794	return SCHEME_V->file_i == 0	1802	return SCHEME_V->file_i == 0
1795	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO	1803	&& SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1796	&& (SCHEME_V->inport->object.port->kind & port_file);	1804	&& (port (SCHEME_V->inport)->kind & port_file);
1797	#else	1805	#else
1798	return 0;	1806	return 0;
1799	#endif	1807	#endif
1800	}	1808	}
1801		1809
1802	#if USE_PORTS	1810	#if USE_PORTS
1803	static port *	1811	ecb_cold static port *
1804	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)	1812	port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1805	{	1813	{
1806	int fd;	1814	int fd;
1807	int flags;	1815	int flags;
1808	char *rw;	1816	char *rw;
…		…
1831	# endif	1839	# endif
1832		1840
1833	return pt;	1841	return pt;
1834	}	1842	}
1835		1843
1836	static pointer	1844	ecb_cold static pointer
1837	port_from_filename (SCHEME_P_ const char *fn, int prop)	1845	port_from_filename (SCHEME_P_ const char *fn, int prop)
1838	{	1846	{
1839	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);	1847	port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1840		1848
1841	if (!pt && USE_ERROR_CHECKING)	1849	if (!pt && USE_ERROR_CHECKING)
1842	return NIL;	1850	return NIL;
1843		1851
1844	return mk_port (SCHEME_A_ pt);	1852	return mk_port (SCHEME_A_ pt);
1845	}	1853	}
1846		1854
1847	static port *	1855	ecb_cold static port *
1848	port_rep_from_file (SCHEME_P_ int f, int prop)	1856	port_rep_from_file (SCHEME_P_ int f, int prop)
1849	{	1857	{
1850	port *pt = malloc (sizeof *pt);	1858	port *pt = malloc (sizeof *pt);
1851		1859
1852	if (!pt && USE_ERROR_CHECKING)	1860	if (!pt && USE_ERROR_CHECKING)
…		…
1857	pt->rep.stdio.file = f;	1865	pt->rep.stdio.file = f;
1858	pt->rep.stdio.closeit = 0;	1866	pt->rep.stdio.closeit = 0;
1859	return pt;	1867	return pt;
1860	}	1868	}
1861		1869
1862	static pointer	1870	ecb_cold static pointer
1863	port_from_file (SCHEME_P_ int f, int prop)	1871	port_from_file (SCHEME_P_ int f, int prop)
1864	{	1872	{
1865	port *pt = port_rep_from_file (SCHEME_A_ f, prop);	1873	port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1866		1874
1867	if (!pt && USE_ERROR_CHECKING)	1875	if (!pt && USE_ERROR_CHECKING)
1868	return NIL;	1876	return NIL;
1869		1877
1870	return mk_port (SCHEME_A_ pt);	1878	return mk_port (SCHEME_A_ pt);
1871	}	1879	}
1872		1880
1873	static port *	1881	ecb_cold static port *
1874	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)
1875	{	1883	{
1876	port *pt = malloc (sizeof (port));	1884	port *pt = malloc (sizeof (port));
1877		1885
1878	if (!pt && USE_ERROR_CHECKING)	1886	if (!pt && USE_ERROR_CHECKING)
…		…
1884	pt->rep.string.curr = start;	1892	pt->rep.string.curr = start;
1885	pt->rep.string.past_the_end = past_the_end;	1893	pt->rep.string.past_the_end = past_the_end;
1886	return pt;	1894	return pt;
1887	}	1895	}
1888		1896
1889	static pointer	1897	ecb_cold static pointer
1890	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)
1891	{	1899	{
1892	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);
1893		1901
1894	if (!pt && USE_ERROR_CHECKING)	1902	if (!pt && USE_ERROR_CHECKING)
…		…
1897	return mk_port (SCHEME_A_ pt);	1905	return mk_port (SCHEME_A_ pt);
1898	}	1906	}
1899		1907
1900	# define BLOCK_SIZE 256	1908	# define BLOCK_SIZE 256
1901		1909
1902	static port *	1910	ecb_cold static port *
1903	port_rep_from_scratch (SCHEME_P)	1911	port_rep_from_scratch (SCHEME_P)
1904	{	1912	{
1905	char *start;	1913	char *start;
1906	port *pt = malloc (sizeof (port));	1914	port *pt = malloc (sizeof (port));
1907		1915
…		…
1921	pt->rep.string.curr = start;	1929	pt->rep.string.curr = start;
1922	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;	1930	pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1923	return pt;	1931	return pt;
1924	}	1932	}
1925		1933
1926	static pointer	1934	ecb_cold static pointer
1927	port_from_scratch (SCHEME_P)	1935	port_from_scratch (SCHEME_P)
1928	{	1936	{
1929	port *pt = port_rep_from_scratch (SCHEME_A);	1937	port *pt = port_rep_from_scratch (SCHEME_A);
1930		1938
1931	if (!pt && USE_ERROR_CHECKING)	1939	if (!pt && USE_ERROR_CHECKING)
1932	return NIL;	1940	return NIL;
1933		1941
1934	return mk_port (SCHEME_A_ pt);	1942	return mk_port (SCHEME_A_ pt);
1935	}	1943	}
1936		1944
1937	static void	1945	ecb_cold static void
1938	port_close (SCHEME_P_ pointer p, int flag)	1946	port_close (SCHEME_P_ pointer p, int flag)
1939	{	1947	{
1940	port *pt = p->object.port;	1948	port *pt = port (p);
1941		1949
1942	pt->kind &= ~flag;	1950	pt->kind &= ~flag;
1943		1951
1944	if ((pt->kind & (port_input | port_output)) == 0)	1952	if ((pt->kind & (port_input | port_output)) == 0)
1945	{	1953	{
…		…
1962	}	1970	}
1963	}	1971	}
1964	#endif	1972	#endif
1965		1973
1966	/* get new character from input file */	1974	/* get new character from input file */
1967	static int	1975	ecb_cold static int
1968	inchar (SCHEME_P)	1976	inchar (SCHEME_P)
1969	{	1977	{
1970	int c;	1978	int c;
1971	port *pt;	1979	port *pt = port (SCHEME_V->inport);
1972
1973	pt = SCHEME_V->inport->object.port;
1974		1980
1975	if (pt->kind & port_saw_EOF)	1981	if (pt->kind & port_saw_EOF)
1976	return EOF;	1982	return EOF;
1977		1983
1978	c = basic_inchar (pt);	1984	c = basic_inchar (pt);
…		…
1988	}	1994	}
1989		1995
1990	return c;	1996	return c;
1991	}	1997	}
1992		1998
1993	static int ungot = -1;	1999	ecb_cold static int
1994
1995	static int
1996	basic_inchar (port *pt)	2000	basic_inchar (port *pt)
1997	{	2001	{
1998	#if USE_PORTS
1999	if (pt->unget != -1)	2002	if (pt->unget != -1)
2000	{	2003	{
2001	int r = pt->unget;	2004	int r = pt->unget;
2002	pt->unget = -1;	2005	pt->unget = -1;
2003	return r;	2006	return r;
2004	}	2007	}
2005		2008
		2009	#if USE_PORTS
2006	if (pt->kind & port_file)	2010	if (pt->kind & port_file)
2007	{	2011	{
2008	char c;	2012	char c;
2009		2013
2010	if (!read (pt->rep.stdio.file, &c, 1))	2014	if (!read (pt->rep.stdio.file, &c, 1))
…		…
2018	return EOF;	2022	return EOF;
2019	else	2023	else
2020	return *pt->rep.string.curr++;	2024	return *pt->rep.string.curr++;
2021	}	2025	}
2022	#else	2026	#else
2023	if (ungot == -1)
2024	{
2025	char c;	2027	char c;
2026	if (!read (0, &c, 1))	2028
		2029	if (!read (pt->rep.stdio.file, &c, 1))
2027	return EOF;	2030	return EOF;
2028		2031
2029	ungot = c;
2030	}
2031
2032	{
2033	int r = ungot;
2034	ungot = -1;
2035	return r;	2032	return c;
2036	}
2037	#endif	2033	#endif
2038	}	2034	}
2039		2035
2040	/* back character to input buffer */	2036	/* back character to input buffer */
2041	static void	2037	ecb_cold static void
2042	backchar (SCHEME_P_ int c)	2038	backchar (SCHEME_P_ int c)
2043	{	2039	{
2044	#if USE_PORTS	2040	port *pt = port (SCHEME_V->inport);
2045	port *pt;
2046		2041
2047	if (c == EOF)	2042	if (c == EOF)
2048	return;	2043	return;
2049		2044
2050	pt = SCHEME_V->inport->object.port;
2051	pt->unget = c;	2045	pt->unget = c;
2052	#else
2053	if (c == EOF)
2054	return;
2055
2056	ungot = c;
2057	#endif
2058	}	2046	}
2059		2047
2060	#if USE_PORTS	2048	#if USE_PORTS
2061	static int	2049	ecb_cold static int
2062	realloc_port_string (SCHEME_P_ port *p)	2050	realloc_port_string (SCHEME_P_ port *p)
2063	{	2051	{
2064	char *start = p->rep.string.start;	2052	char *start = p->rep.string.start;
2065	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;
2066	char *str = malloc (new_size);	2054	char *str = malloc (new_size);
…		…
2079	else	2067	else
2080	return 0;	2068	return 0;
2081	}	2069	}
2082	#endif	2070	#endif
2083		2071
2084	INTERFACE void	2072	ecb_cold static void
2085	putstr (SCHEME_P_ const char *s)	2073	putchars (SCHEME_P_ const char *s, int len)
2086	{	2074	{
		2075	port *pt = port (SCHEME_V->outport);
		2076
2087	#if USE_PORTS	2077	#if USE_PORTS
2088	port *pt = SCHEME_V->outport->object.port;
2089
2090	if (pt->kind & port_file)
2091	write (pt->rep.stdio.file, s, strlen (s));
2092	else
2093	for (; *s; s++)
2094	if (pt->rep.string.curr != pt->rep.string.past_the_end)
2095	*pt->rep.string.curr++ = *s;
2096	else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2097	*pt->rep.string.curr++ = *s;
2098
2099	#else
2100	xwrstr (s);
2101	#endif
2102	}
2103
2104	static void
2105	putchars (SCHEME_P_ const char *s, int len)
2106	{
2107	#if USE_PORTS
2108	port *pt = SCHEME_V->outport->object.port;
2109
2110	if (pt->kind & port_file)	2078	if (pt->kind & port_file)
2111	write (pt->rep.stdio.file, s, len);	2079	write (pt->rep.stdio.file, s, len);
2112	else	2080	else
2113	{	2081	{
2114	for (; len; len--)	2082	for (; len; len--)
…		…
2119	*pt->rep.string.curr++ = *s++;	2087	*pt->rep.string.curr++ = *s++;
2120	}	2088	}
2121	}	2089	}
2122		2090
2123	#else	2091	#else
2124	write (1, s, len);	2092	write (1, s, len); // output not initialised
2125	#endif	2093	#endif
		2094	}
		2095
		2096	INTERFACE void
		2097	putstr (SCHEME_P_ const char *s)
		2098	{
		2099	putchars (SCHEME_A_ s, strlen (s));
2126	}	2100	}
2127		2101
2128	INTERFACE void	2102	INTERFACE void
2129	putcharacter (SCHEME_P_ int c)	2103	putcharacter (SCHEME_P_ int c)
2130	{	2104	{
2131	#if USE_PORTS
2132	port *pt = SCHEME_V->outport->object.port;
2133
2134	if (pt->kind & port_file)
2135	{
2136	char cc = c;
2137	write (pt->rep.stdio.file, &cc, 1);
2138	}
2139	else
2140	{
2141	if (pt->rep.string.curr != pt->rep.string.past_the_end)
2142	*pt->rep.string.curr++ = c;
2143	else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2144	*pt->rep.string.curr++ = c;
2145	}
2146
2147	#else
2148	char cc = c;	2105	char cc = c;
2149	write (1, &c, 1);	2106
2150	#endif	2107	putchars (SCHEME_A_ &cc, 1);
2151	}	2108	}
2152		2109
2153	/* read characters up to delimiter, but cater to character constants */	2110	/* read characters up to delimiter, but cater to character constants */
2154	static char *	2111	ecb_cold static char *
2155	readstr_upto (SCHEME_P_ int skip, const char *delim)	2112	readstr_upto (SCHEME_P_ int skip, const char *delim)
2156	{	2113	{
2157	char *p = SCHEME_V->strbuff + skip;	2114	char *p = SCHEME_V->strbuff + skip;
2158		2115
2159	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))));
…		…
2168		2125
2169	return SCHEME_V->strbuff;	2126	return SCHEME_V->strbuff;
2170	}	2127	}
2171		2128
2172	/* read string expression "xxx...xxx" */	2129	/* read string expression "xxx...xxx" */
2173	static pointer	2130	ecb_cold static pointer
2174	readstrexp (SCHEME_P_ char delim)	2131	readstrexp (SCHEME_P_ char delim)
2175	{	2132	{
2176	char *p = SCHEME_V->strbuff;	2133	char *p = SCHEME_V->strbuff;
2177	int c;	2134	int c;
2178	int c1 = 0;	2135	int c1 = 0;
…		…
2211	case '7':	2168	case '7':
2212	state = st_oct1;	2169	state = st_oct1;
2213	c1 = c - '0';	2170	c1 = c - '0';
2214	break;	2171	break;
2215		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
2216	case 'x':	2188	case 'x':
2217	case 'X':	2189	case 'X':
2218	state = st_x1;	2190	state = st_x1;
2219	c1 = 0;	2191	c1 = 0;
2220	break;
2221
2222	case 'n':
2223	*p++ = '\n';
2224	state = st_ok;
2225	break;
2226
2227	case 't':
2228	*p++ = '\t';
2229	state = st_ok;
2230	break;
2231
2232	case 'r':
2233	*p++ = '\r';
2234	state = st_ok;
2235	break;	2192	break;
2236		2193
2237	default:	2194	default:
2238	*p++ = c;	2195	*p++ = c;
2239	state = st_ok;	2196	state = st_ok;
…		…
2291	}	2248	}
2292	}	2249	}
2293	}	2250	}
2294		2251
2295	/* check c is in chars */	2252	/* check c is in chars */
2296	ecb_inline int	2253	ecb_cold int
2297	is_one_of (const char *s, int c)	2254	is_one_of (const char *s, int c)
2298	{	2255	{
2299	return c == EOF || !!strchr (s, c);	2256	return c == EOF || !!strchr (s, c);
2300	}	2257	}
2301		2258
2302	/* skip white characters */	2259	/* skip white characters */
2303	ecb_inline int	2260	ecb_cold int
2304	skipspace (SCHEME_P)	2261	skipspace (SCHEME_P)
2305	{	2262	{
2306	int c, curr_line = 0;	2263	int c, curr_line = 0;
2307		2264
2308	do	2265	do
…		…
2328	backchar (SCHEME_A_ c);	2285	backchar (SCHEME_A_ c);
2329	return 1;	2286	return 1;
2330	}	2287	}
2331		2288
2332	/* get token */	2289	/* get token */
2333	static int	2290	ecb_cold static int
2334	token (SCHEME_P)	2291	token (SCHEME_P)
2335	{	2292	{
2336	int c = skipspace (SCHEME_A);	2293	int c = skipspace (SCHEME_A);
2337		2294
2338	if (c == EOF)	2295	if (c == EOF)
…		…
2436	}	2393	}
2437		2394
2438	/* ========== Routines for Printing ========== */	2395	/* ========== Routines for Printing ========== */
2439	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)	2396	#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2440		2397
2441	static void	2398	ecb_cold static void
2442	printslashstring (SCHEME_P_ char *p, int len)	2399	printslashstring (SCHEME_P_ char *p, int len)
2443	{	2400	{
2444	int i;	2401	int i;
2445	unsigned char *s = (unsigned char *) p;	2402	unsigned char *s = (unsigned char *) p;
2446		2403
…		…
2502		2459
2503	putcharacter (SCHEME_A_ '"');	2460	putcharacter (SCHEME_A_ '"');
2504	}	2461	}
2505		2462
2506	/* print atoms */	2463	/* print atoms */
2507	static void	2464	ecb_cold static void
2508	printatom (SCHEME_P_ pointer l, int f)	2465	printatom (SCHEME_P_ pointer l, int f)
2509	{	2466	{
2510	char *p;	2467	char *p;
2511	int len;	2468	int len;
2512		2469
2513	atom2str (SCHEME_A_ l, f, &p, &len);	2470	atom2str (SCHEME_A_ l, f, &p, &len);
2514	putchars (SCHEME_A_ p, len);	2471	putchars (SCHEME_A_ p, len);
2515	}	2472	}
2516		2473
2517	/* Uses internal buffer unless string pointer is already available */	2474	/* Uses internal buffer unless string pointer is already available */
2518	static void	2475	ecb_cold static void
2519	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)	2476	atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2520	{	2477	{
2521	char *p;	2478	char *p;
2522		2479
2523	if (l == NIL)	2480	if (l == NIL)
…		…
2656	}	2613	}
2657	else if (is_symbol (l))	2614	else if (is_symbol (l))
2658	p = symname (l);	2615	p = symname (l);
2659	else if (is_proc (l))	2616	else if (is_proc (l))
2660	{	2617	{
		2618	p = (char *)procname (l); // ok with r7rs display, but not r7rs write
		2619	#if 0
2661	#if USE_PRINTF	2620	#if USE_PRINTF
2662	p = SCHEME_V->strbuff;	2621	p = SCHEME_V->strbuff;
2663	snprintf (p, STRBUFFSIZE, "#<%s PROCEDURE %ld>", procname (l), procnum (l));	2622	snprintf (p, STRBUFFSIZE, " PROCEDURE %ld>", procname (l), procnum (l));
2664	#else	2623	#else
2665	p = "#<PROCEDURE>";	2624	p = "#<PROCEDURE>";
		2625	#endif
2666	#endif	2626	#endif
2667	}	2627	}
2668	else if (is_macro (l))	2628	else if (is_macro (l))
2669	p = "#<MACRO>";	2629	p = "#<MACRO>";
2670	else if (is_closure (l))	2630	else if (is_closure (l))
…		…
2730	return car (d);	2690	return car (d);
2731		2691
2732	p = cons (car (d), cdr (d));	2692	p = cons (car (d), cdr (d));
2733	q = p;	2693	q = p;
2734		2694
2735	while (cdr (cdr (p)) != NIL)	2695	while (cddr (p) != NIL)
2736	{	2696	{
2737	d = cons (car (p), cdr (p));	2697	d = cons (car (p), cdr (p));
2738		2698
2739	if (cdr (cdr (p)) != NIL)	2699	if (cddr (p) != NIL)
2740	p = cdr (d);	2700	p = cdr (d);
2741	}	2701	}
2742		2702
2743	set_cdr (p, car (cdr (p)));	2703	set_cdr (p, cadr (p));
2744	return q;	2704	return q;
2745	}	2705	}
2746		2706
2747	/* reverse list -- produce new list */	2707	/* reverse list -- produce new list */
2748	static pointer	2708	ecb_hot static pointer
2749	reverse (SCHEME_P_ pointer a)	2709	reverse (SCHEME_P_ pointer a)
2750	{	2710	{
2751	/* a must be checked by gc */	2711	/* a must be checked by gc */
2752	pointer p = NIL;	2712	pointer p = NIL;
2753		2713
…		…
2756		2716
2757	return p;	2717	return p;
2758	}	2718	}
2759		2719
2760	/* reverse list --- in-place */	2720	/* reverse list --- in-place */
2761	static pointer	2721	ecb_hot static pointer
2762	reverse_in_place (SCHEME_P_ pointer term, pointer list)	2722	reverse_in_place (SCHEME_P_ pointer term, pointer list)
2763	{	2723	{
2764	pointer result = term;	2724	pointer result = term;
2765	pointer p = list;	2725	pointer p = list;
2766		2726
…		…
2774		2734
2775	return result;	2735	return result;
2776	}	2736	}
2777		2737
2778	/* append list -- produce new list (in reverse order) */	2738	/* append list -- produce new list (in reverse order) */
2779	static pointer	2739	ecb_hot static pointer
2780	revappend (SCHEME_P_ pointer a, pointer b)	2740	revappend (SCHEME_P_ pointer a, pointer b)
2781	{	2741	{
2782	pointer result = a;	2742	pointer result = a;
2783	pointer p = b;	2743	pointer p = b;
2784		2744
…		…
2793		2753
2794	return S_F; /* signal an error */	2754	return S_F; /* signal an error */
2795	}	2755	}
2796		2756
2797	/* equivalence of atoms */	2757	/* equivalence of atoms */
2798	int	2758	ecb_hot int
2799	eqv (pointer a, pointer b)	2759	eqv (pointer a, pointer b)
2800	{	2760	{
2801	if (is_string (a))	2761	if (is_string (a))
2802	{	2762	{
2803	if (is_string (b))	2763	if (is_string (b))
…		…
2860	{	2820	{
2861	pointer new_frame;	2821	pointer new_frame;
2862		2822
2863	/* The interaction-environment has about 300 variables in it. */	2823	/* The interaction-environment has about 300 variables in it. */
2864	if (old_env == NIL)	2824	if (old_env == NIL)
2865	new_frame = mk_vector (SCHEME_A_ 461);	2825	new_frame = mk_vector (SCHEME_A_ 29); // was 461
2866	else	2826	else
2867	new_frame = NIL;	2827	new_frame = NIL;
2868		2828
2869	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2829	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2870	setenvironment (SCHEME_V->envir);	2830	setenvironment (SCHEME_V->envir);
…		…
2897	}	2857	}
2898	else	2858	else
2899	set_car (env, immutable_cons (slot, car (env)));	2859	set_car (env, immutable_cons (slot, car (env)));
2900	}	2860	}
2901		2861
2902	static pointer	2862	ecb_hot static pointer
2903	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)	2863	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2904	{	2864	{
2905	pointer x, y;	2865	pointer x, y;
2906		2866
2907	for (x = env; x != NIL; x = cdr (x))	2867	for (x = env; x != NIL; x = cdr (x))
…		…
2928	return NIL;	2888	return NIL;
2929	}	2889	}
2930		2890
2931	#else /* USE_ALIST_ENV */	2891	#else /* USE_ALIST_ENV */
2932		2892
2933	ecb_inline void	2893	static void
2934	new_frame_in_env (SCHEME_P_ pointer old_env)	2894	new_frame_in_env (SCHEME_P_ pointer old_env)
2935	{	2895	{
2936	SCHEME_V->envir = immutable_cons (NIL, old_env);	2896	SCHEME_V->envir = immutable_cons (NIL, old_env);
2937	setenvironment (SCHEME_V->envir);	2897	setenvironment (SCHEME_V->envir);
2938	}	2898	}
2939		2899
2940	ecb_inline void	2900	static void
2941	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2901	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2942	{	2902	{
2943	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2903	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2944	}	2904	}
2945		2905
2946	static pointer	2906	ecb_hot static pointer
2947	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)	2907	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2948	{	2908	{
2949	pointer x, y;	2909	pointer x, y;
2950		2910
2951	for (x = env; x != NIL; x = cdr (x))	2911	for (x = env; x != NIL; x = cdr (x))
…		…
2965	return NIL;	2925	return NIL;
2966	}	2926	}
2967		2927
2968	#endif /* USE_ALIST_ENV else */	2928	#endif /* USE_ALIST_ENV else */
2969		2929
2970	ecb_inline void	2930	static void
2971	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2931	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2972	{	2932	{
2973	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2	2933	assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2974	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);	2934	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2975	}	2935	}
2976		2936
2977	ecb_inline void	2937	static void
2978	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2938	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2979	{	2939	{
2980	set_cdr (slot, value);	2940	set_cdr (slot, value);
2981	}	2941	}
2982		2942
2983	ecb_inline pointer	2943	static pointer
2984	slot_value_in_env (pointer slot)	2944	slot_value_in_env (pointer slot)
2985	{	2945	{
2986	return cdr (slot);	2946	return cdr (slot);
2987	}	2947	}
2988		2948
2989	/* ========== Evaluation Cycle ========== */	2949	/* ========== Evaluation Cycle ========== */
2990		2950
2991	static int	2951	ecb_cold static int
2992	xError_1 (SCHEME_P_ const char *s, pointer a)	2952	xError_1 (SCHEME_P_ const char *s, pointer a)
2993	{	2953	{
2994	#if USE_ERROR_HOOK
2995	pointer x;
2996	pointer hdl = SCHEME_V->ERROR_HOOK;
2997	#endif
2998
2999	#if USE_PRINTF	2954	#if USE_PRINTF
3000	#if SHOW_ERROR_LINE	2955	#if SHOW_ERROR_LINE
3001	char sbuf[STRBUFFSIZE];	2956	char sbuf[STRBUFFSIZE];
3002		2957
3003	/* make sure error is not in REPL */	2958	/* make sure error is not in REPL */
…		…
3018	}	2973	}
3019	#endif	2974	#endif
3020	#endif	2975	#endif
3021		2976
3022	#if USE_ERROR_HOOK	2977	#if USE_ERROR_HOOK
3023	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);	2978	pointer x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->ERROR_HOOK, 1);
3024		2979
3025	if (x != NIL)	2980	if (x != NIL)
3026	{	2981	{
3027	pointer code = a	2982	pointer code = a
3028	? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)	2983	? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
…		…
3072	pointer code;	3027	pointer code;
3073	};	3028	};
3074		3029
3075	# define STACK_GROWTH 3	3030	# define STACK_GROWTH 3
3076		3031
3077	static void	3032	ecb_hot static void
3078	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)	3033	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3079	{	3034	{
3080	int nframes = (uintptr_t)SCHEME_V->dump;	3035	int nframes = (uintptr_t)SCHEME_V->dump;
3081	struct dump_stack_frame *next_frame;	3036	struct dump_stack_frame *next_frame;
3082		3037
3083	/* enough room for the next frame? */	3038	/* enough room for the next frame? */
3084	if (nframes >= SCHEME_V->dump_size)	3039	if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3085	{	3040	{
3086	SCHEME_V->dump_size += STACK_GROWTH;	3041	SCHEME_V->dump_size += STACK_GROWTH;
3087	SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);	3042	SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3088	}	3043	}
3089		3044
…		…
3095	next_frame->code = code;	3050	next_frame->code = code;
3096		3051
3097	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3052	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3098	}	3053	}
3099		3054
3100	static int	3055	static ecb_hot int
3101	xs_return (SCHEME_P_ pointer a)	3056	xs_return (SCHEME_P_ pointer a)
3102	{	3057	{
3103	int nframes = (uintptr_t)SCHEME_V->dump;	3058	int nframes = (uintptr_t)SCHEME_V->dump;
3104	struct dump_stack_frame *frame;	3059	struct dump_stack_frame *frame;
3105		3060
…		…
3116	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3071	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3117		3072
3118	return 0;	3073	return 0;
3119	}	3074	}
3120		3075
3121	ecb_inline void	3076	ecb_cold void
3122	dump_stack_reset (SCHEME_P)	3077	dump_stack_reset (SCHEME_P)
3123	{	3078	{
3124	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */	3079	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3125	SCHEME_V->dump = (pointer)+0;	3080	SCHEME_V->dump = (pointer)+0;
3126	}	3081	}
3127		3082
3128	ecb_inline void	3083	ecb_cold void
3129	dump_stack_initialize (SCHEME_P)	3084	dump_stack_initialize (SCHEME_P)
3130	{	3085	{
3131	SCHEME_V->dump_size = 0;	3086	SCHEME_V->dump_size = 0;
3132	SCHEME_V->dump_base = 0;	3087	SCHEME_V->dump_base = 0;
3133	dump_stack_reset (SCHEME_A);	3088	dump_stack_reset (SCHEME_A);
3134	}	3089	}
3135		3090
3136	static void	3091	ecb_cold static void
3137	dump_stack_free (SCHEME_P)	3092	dump_stack_free (SCHEME_P)
3138	{	3093	{
3139	free (SCHEME_V->dump_base);	3094	free (SCHEME_V->dump_base);
3140	SCHEME_V->dump_base = 0;	3095	SCHEME_V->dump_base = 0;
3141	SCHEME_V->dump = (pointer)0;	3096	SCHEME_V->dump = (pointer)0;
3142	SCHEME_V->dump_size = 0;	3097	SCHEME_V->dump_size = 0;
3143	}	3098	}
3144		3099
3145	static void	3100	ecb_cold static void
3146	dump_stack_mark (SCHEME_P)	3101	dump_stack_mark (SCHEME_P)
3147	{	3102	{
3148	int nframes = (uintptr_t)SCHEME_V->dump;	3103	int nframes = (uintptr_t)SCHEME_V->dump;
3149	int i;	3104	int i;
3150		3105
…		…
3156	mark (frame->envir);	3111	mark (frame->envir);
3157	mark (frame->code);	3112	mark (frame->code);
3158	}	3113	}
3159	}	3114	}
3160		3115
3161	static pointer	3116	ecb_cold static pointer
3162	ss_get_cont (SCHEME_P)	3117	ss_get_cont (SCHEME_P)
3163	{	3118	{
3164	int nframes = (uintptr_t)SCHEME_V->dump;	3119	int nframes = (uintptr_t)SCHEME_V->dump;
3165	int i;	3120	int i;
3166		3121
…		…
3178	}	3133	}
3179		3134
3180	return cont;	3135	return cont;
3181	}	3136	}
3182		3137
3183	static void	3138	ecb_cold static void
3184	ss_set_cont (SCHEME_P_ pointer cont)	3139	ss_set_cont (SCHEME_P_ pointer cont)
3185	{	3140	{
3186	int i = 0;	3141	int i = 0;
3187	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3142	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3188		3143
…		…
3200	SCHEME_V->dump = (pointer)(uintptr_t)i;	3155	SCHEME_V->dump = (pointer)(uintptr_t)i;
3201	}	3156	}
3202		3157
3203	#else	3158	#else
3204		3159
3205	ecb_inline void	3160	ecb_cold void
3206	dump_stack_reset (SCHEME_P)	3161	dump_stack_reset (SCHEME_P)
3207	{	3162	{
3208	SCHEME_V->dump = NIL;	3163	SCHEME_V->dump = NIL;
3209	}	3164	}
3210		3165
3211	ecb_inline void	3166	ecb_cold void
3212	dump_stack_initialize (SCHEME_P)	3167	dump_stack_initialize (SCHEME_P)
3213	{	3168	{
3214	dump_stack_reset (SCHEME_A);	3169	dump_stack_reset (SCHEME_A);
3215	}	3170	}
3216		3171
3217	static void	3172	ecb_cold static void
3218	dump_stack_free (SCHEME_P)	3173	dump_stack_free (SCHEME_P)
3219	{	3174	{
3220	SCHEME_V->dump = NIL;	3175	SCHEME_V->dump = NIL;
3221	}	3176	}
3222		3177
3223	static int	3178	ecb_hot static int
3224	xs_return (SCHEME_P_ pointer a)	3179	xs_return (SCHEME_P_ pointer a)
3225	{	3180	{
3226	pointer dump = SCHEME_V->dump;	3181	pointer dump = SCHEME_V->dump;
3227		3182
3228	SCHEME_V->value = a;	3183	SCHEME_V->value = a;
…		…
3238	SCHEME_V->dump = dump;	3193	SCHEME_V->dump = dump;
3239		3194
3240	return 0;	3195	return 0;
3241	}	3196	}
3242		3197
3243	static void	3198	ecb_hot static void
3244	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)	3199	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3245	{	3200	{
3246	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),	3201	SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3247	cons (args,	3202	cons (args,
3248	cons (SCHEME_V->envir,	3203	cons (SCHEME_V->envir,
3249	cons (code,	3204	cons (code,
3250	SCHEME_V->dump))));	3205	SCHEME_V->dump))));
3251	}	3206	}
3252		3207
3253	static void	3208	ecb_cold static void
3254	dump_stack_mark (SCHEME_P)	3209	dump_stack_mark (SCHEME_P)
3255	{	3210	{
3256	mark (SCHEME_V->dump);	3211	mark (SCHEME_V->dump);
3257	}	3212	}
3258		3213
3259	static pointer	3214	ecb_cold static pointer
3260	ss_get_cont (SCHEME_P)	3215	ss_get_cont (SCHEME_P)
3261	{	3216	{
3262	return SCHEME_V->dump;	3217	return SCHEME_V->dump;
3263	}	3218	}
3264		3219
3265	static void	3220	ecb_cold static void
3266	ss_set_cont (SCHEME_P_ pointer cont)	3221	ss_set_cont (SCHEME_P_ pointer cont)
3267	{	3222	{
3268	SCHEME_V->dump = cont;	3223	SCHEME_V->dump = cont;
3269	}	3224	}
3270		3225
3271	#endif	3226	#endif
3272		3227
3273	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3228	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3274		3229
3275	#if EXPERIMENT	3230	#if EXPERIMENT
		3231
3276	static int	3232	static int
3277	debug (SCHEME_P_ int indent, pointer x)	3233	dtree (SCHEME_P_ int indent, pointer x)
3278	{	3234	{
3279	int c;	3235	int c;
3280		3236
3281	if (is_syntax (x))	3237	if (is_syntax (x))
3282	{	3238	{
…		…
3300	printf ("%*sS<%s>\n", indent, "", symname (x));	3256	printf ("%*sS<%s>\n", indent, "", symname (x));
3301	return 24+8;	3257	return 24+8;
3302		3258
3303	case T_CLOSURE:	3259	case T_CLOSURE:
3304	printf ("%*sS<%s>\n", indent, "", "closure");	3260	printf ("%*sS<%s>\n", indent, "", "closure");
3305	debug (SCHEME_A_ indent + 3, cdr(x));	3261	dtree (SCHEME_A_ indent + 3, cdr(x));
3306	return 32 + debug (SCHEME_A_ indent + 3, car (x));	3262	return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3307		3263
3308	case T_PAIR:	3264	case T_PAIR:
3309	printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));	3265	printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3310	c = debug (SCHEME_A_ indent + 3, car (x));	3266	c = dtree (SCHEME_A_ indent + 3, car (x));
3311	c += debug (SCHEME_A_ indent + 3, cdr (x));	3267	c += dtree (SCHEME_A_ indent + 3, cdr (x));
3312	return c + 1;	3268	return c + 1;
3313		3269
3314	case T_PORT:	3270	case T_PORT:
3315	printf ("%*sS<%s>\n", indent, "", "port");	3271	printf ("%*sS<%s>\n", indent, "", "port");
3316	return 24+8;	3272	return 24+8;
…		…
3319	printf ("%*sS<%s>\n", indent, "", "vector");	3275	printf ("%*sS<%s>\n", indent, "", "vector");
3320	return 24+8;	3276	return 24+8;
3321		3277
3322	case T_ENVIRONMENT:	3278	case T_ENVIRONMENT:
3323	printf ("%*sS<%s>\n", indent, "", "environment");	3279	printf ("%*sS<%s>\n", indent, "", "environment");
3324	return 0 + debug (SCHEME_A_ indent + 3, car (x));	3280	return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3325		3281
3326	default:	3282	default:
3327	printf ("unhandled type %d\n", type (x));	3283	printf ("unhandled type %d\n", type (x));
3328	break;	3284	break;
3329	}	3285	}
3330	}	3286	}
3331	#endif
3332		3287
		3288	#define DUMP(t) do { printf ("DUMP %s:%d\n", __FILE__, __LINE__); dtree (SCHEME_A_ 0, (t)); } while (0)
		3289
		3290	typedef void *stream[1];
		3291
		3292	#define stream_init() { 0 }
		3293	#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
		3294	#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
		3295	#define stream_free(s) free (s[0])
		3296
		3297	ecb_cold static void
		3298	stream_put (stream s, uint8_t byte)
		3299	{
		3300	uint32_t *sp = *s;
		3301	uint32_t size = sizeof (uint32_t) * 2;
		3302	uint32_t offs = size;
		3303
		3304	if (ecb_expect_true (sp))
		3305	{
		3306	offs = sp[0];
		3307	size = sp[1];
		3308	}
		3309
		3310	if (ecb_expect_false (offs == size))
		3311	{
		3312	size *= 2;
		3313	sp = realloc (sp, size);
		3314	*s = sp;
		3315	sp[1] = size;
		3316
		3317	}
		3318
		3319	((uint8_t *)sp)[offs++] = byte;
		3320	sp[0] = offs;
		3321	}
		3322
		3323	ecb_cold static void
		3324	stream_put_v (stream s, uint32_t v)
		3325	{
		3326	while (v > 0x7f)
		3327	{
		3328	stream_put (s, v | 0x80);
		3329	v >>= 7;
		3330	}
		3331
		3332	stream_put (s, v);
		3333	}
		3334
		3335	ecb_cold static void
		3336	stream_put_tv (stream s, int bop, uint32_t v)
		3337	{
		3338	printf ("put tv %d %d\n", bop, v);//D
		3339	stream_put (s, bop);
		3340	stream_put_v (s, v);
		3341	}
		3342
		3343	ecb_cold static void
		3344	stream_put_stream (stream s, stream o)
		3345	{
		3346	uint32_t i;
		3347
		3348	for (i = 0; i < stream_size (o); ++i)
		3349	stream_put (s, stream_data (o)[i]);
		3350
		3351	stream_free (o);
		3352	}
		3353
		3354	ecb_cold static uint32_t
		3355	cell_id (SCHEME_P_ pointer x)
		3356	{
		3357	struct cell *p = CELL (x);
		3358	int i;
		3359
		3360	for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
		3361	if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
		3362	return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
		3363
		3364	abort ();
		3365	}
		3366
		3367	// calculates a (preferably small) integer that makes it possible to find
		3368	// the symbol again. if pointers were offsets into a memory area... until
		3369	// then, we return segment number in the low bits, and offset in the high
		3370	// bits.
		3371	// also, this function must never return 0.
		3372	ecb_cold static uint32_t
		3373	symbol_id (SCHEME_P_ pointer sym)
		3374	{
		3375	return cell_id (SCHEME_A_ sym);
		3376	}
		3377
		3378	enum byteop
		3379	{
		3380	BOP_NIL,
		3381	BOP_INTEGER,
		3382	BOP_SYMBOL,
		3383	BOP_DATUM,
		3384	BOP_LIST_BEG,
		3385	BOP_LIST_END,
		3386	BOP_IF,
		3387	BOP_AND,
		3388	BOP_OR,
		3389	BOP_CASE,
		3390	BOP_COND,
		3391	BOP_LET,
		3392	BOP_LETAST,
		3393	BOP_LETREC,
		3394	BOP_DEFINE,
		3395	BOP_MACRO,
		3396	BOP_SET,
		3397	BOP_BEGIN,
		3398	BOP_LAMBDA,
		3399	BOP_DELAY,
		3400	BOP_OP,
		3401	};
		3402
		3403	ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
		3404
		3405	ecb_cold static void
		3406	compile_list (SCHEME_P_ stream s, pointer x)
		3407	{
		3408	// TODO: improper list
		3409
		3410	for (; x != NIL; x = cdr (x))
		3411	{
		3412	stream t = stream_init ();
		3413	compile_expr (SCHEME_A_ t, car (x));
		3414	stream_put_v (s, stream_size (t));
		3415	stream_put_stream (s, t);
		3416	}
		3417
		3418	stream_put_v (s, 0);
		3419	}
		3420
		3421	static void
		3422	compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
		3423	{
		3424	stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
		3425
		3426	stream_put (s, BOP_IF);
		3427	compile_expr (SCHEME_A_ s, cond);
		3428	stream_put_v (s, stream_size (sift));
		3429	stream_put_stream (s, sift);
		3430	compile_expr (SCHEME_A_ s, iff);
		3431	}
		3432
		3433	typedef uint32_t stream_fixup;
		3434
		3435	static stream_fixup
		3436	stream_put_fixup (stream s)
		3437	{
		3438	stream_put (s, 0);
		3439	stream_put (s, 0);
		3440
		3441	return stream_size (s);
		3442	}
		3443
		3444	static void
		3445	stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target)
		3446	{
		3447	target -= fixup;
		3448	assert (target < (1 << 14));
		3449	stream_data (s)[fixup - 2] = target | 0x80;
		3450	stream_data (s)[fixup - 1] = target >> 7;
		3451	}
		3452
		3453	static void
		3454	compile_and_or (SCHEME_P_ stream s, int and, pointer x)
		3455	{
		3456	for (; cdr (x) != NIL; x = cdr (x))
		3457	{
		3458	stream t = stream_init ();
		3459	compile_expr (SCHEME_A_ t, car (x));
		3460	stream_put_v (s, stream_size (t));
		3461	stream_put_stream (s, t);
		3462	}
		3463
		3464	stream_put_v (s, 0);
		3465	}
		3466
		3467	static void
		3468	compile_case (SCHEME_P_ stream s, pointer x)
		3469	{
		3470	compile_expr (SCHEME_A_ s, caar (x));
		3471
		3472	for (;;)
		3473	{
		3474	x = cdr (x);
		3475
		3476	if (x == NIL)
		3477	break;
		3478
		3479	compile_expr (SCHEME_A_ s, caar (x));
		3480	stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
		3481	stream_put_v (s, stream_size (t));
		3482	stream_put_stream (s, t);
		3483	}
		3484
		3485	stream_put_v (s, 0);
		3486	}
		3487
		3488	static void
		3489	compile_cond (SCHEME_P_ stream s, pointer x)
		3490	{
		3491	for ( ; x != NIL; x = cdr (x))
		3492	{
		3493	compile_expr (SCHEME_A_ s, caar (x));
		3494	stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
		3495	stream_put_v (s, stream_size (t));
		3496	stream_put_stream (s, t);
		3497	}
		3498
		3499	stream_put_v (s, 0);
		3500	}
		3501
3333	static int	3502	static pointer
		3503	lookup (SCHEME_P_ pointer x)
		3504	{
		3505	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, x, 1);
		3506
		3507	if (x != NIL)
		3508	x = slot_value_in_env (x);
		3509
		3510	return x;
		3511	}
		3512
		3513	ecb_cold static void
		3514	compile_expr (SCHEME_P_ stream s, pointer x)
		3515	{
		3516	if (x == NIL)
		3517	{
		3518	stream_put (s, BOP_NIL);
		3519	return;
		3520	}
		3521
		3522	if (is_pair (x))
		3523	{
		3524	pointer head = car (x);
		3525
		3526	if (is_syntax (head))
		3527	{
		3528	int syn = syntaxnum (head);
		3529	x = cdr (x);
		3530
		3531	switch (syntaxnum (head))
		3532	{
		3533	case OP_IF0: /* if */
		3534	stream_put_v (s, BOP_IF);
		3535	compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
		3536	break;
		3537
		3538	case OP_OR0: /* or */
		3539	stream_put_v (s, BOP_OR);
		3540	compile_and_or (SCHEME_A_ s, 0, x);
		3541	break;
		3542
		3543	case OP_AND0: /* and */
		3544	stream_put_v (s, BOP_AND);
		3545	compile_and_or (SCHEME_A_ s, 1, x);
		3546	break;
		3547
		3548	case OP_CASE0: /* case */
		3549	stream_put_v (s, BOP_CASE);
		3550	compile_case (SCHEME_A_ s, x);
		3551	break;
		3552
		3553	case OP_COND0: /* cond */
		3554	stream_put_v (s, BOP_COND);
		3555	compile_cond (SCHEME_A_ s, x);
		3556	break;
		3557
		3558	case OP_LET0: /* let */
		3559	case OP_LET0AST: /* let* */
		3560	case OP_LET0REC: /* letrec */
		3561	switch (syn)
		3562	{
		3563	case OP_LET0: stream_put (s, BOP_LET ); break;
		3564	case OP_LET0AST: stream_put (s, BOP_LETAST); break;
		3565	case OP_LET0REC: stream_put (s, BOP_LETREC); break;
		3566	}
		3567
		3568	{
		3569	pointer bindings = car (x);
		3570	pointer body = cadr (x);
		3571
		3572	for (x = bindings; x != NIL; x = cdr (x))
		3573	{
		3574	pointer init = NIL;
		3575	pointer var = car (x);
		3576
		3577	if (is_pair (var))
		3578	{
		3579	init = cdr (var);
		3580	var = car (var);
		3581	}
		3582
		3583	stream_put_v (s, symbol_id (SCHEME_A_ var));
		3584	compile_expr (SCHEME_A_ s, init);
		3585	}
		3586
		3587	stream_put_v (s, 0);
		3588	compile_expr (SCHEME_A_ s, body);
		3589	}
		3590	break;
		3591
		3592	case OP_DEF0: /* define */
		3593	case OP_MACRO0: /* macro */
		3594	stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO);
		3595	stream_put_v (s, cell_id (SCHEME_A_ car (x)));
		3596	compile_expr (SCHEME_A_ s, cadr (x));
		3597	break;
		3598
		3599	case OP_SET0: /* set! */
		3600	stream_put (s, BOP_SET);
		3601	stream_put_v (s, symbol_id (SCHEME_A_ car (x)));
		3602	compile_expr (SCHEME_A_ s, cadr (x));
		3603	break;
		3604
		3605	case OP_BEGIN: /* begin */
		3606	stream_put (s, BOP_BEGIN);
		3607	compile_list (SCHEME_A_ s, x);
		3608	return;
		3609
		3610	case OP_QUOTE: /* quote */
		3611	stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
		3612	break;
		3613
		3614	case OP_DELAY: /* delay */
		3615	stream_put (s, BOP_DELAY);
		3616	compile_expr (SCHEME_A_ s, x);
		3617	break;
		3618
		3619	case OP_LAMBDA: /* lambda */
		3620	{
		3621	pointer formals = car (x);
		3622	pointer body = cadr (x);
		3623
		3624	stream_put (s, BOP_LAMBDA);
		3625
		3626	for (; is_pair (formals); formals = cdr (formals))
		3627	stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
		3628
		3629	stream_put_v (s, 0);
		3630	stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals));
		3631
		3632	compile_expr (SCHEME_A_ s, body);
		3633	}
		3634	break;
		3635
		3636	case OP_C0STREAM:/* cons-stream */
		3637	abort ();
		3638	break;
		3639	}
		3640
		3641	return;
		3642	}
		3643
		3644	pointer m = lookup (SCHEME_A_ head);
		3645
		3646	if (is_macro (m))
		3647	{
		3648	s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
		3649	SCHEME_V->code = m;
		3650	SCHEME_V->args = cons (x, NIL);
		3651	Eval_Cycle (SCHEME_A_ OP_APPLY);
		3652	x = SCHEME_V->value;
		3653	compile_expr (SCHEME_A_ s, SCHEME_V->value);
		3654	return;
		3655	}
		3656
		3657	stream_put (s, BOP_LIST_BEG);
		3658
		3659	for (; x != NIL; x = cdr (x))
		3660	compile_expr (SCHEME_A_ s, car (x));
		3661
		3662	stream_put (s, BOP_LIST_END);
		3663	return;
		3664	}
		3665
		3666	switch (type (x))
		3667	{
		3668	case T_INTEGER:
		3669	{
		3670	IVALUE iv = ivalue_unchecked (x);
		3671	iv = iv < 0 ? ((~(uint32_t)iv) << 1) | 1 : (uint32_t)iv << 1;
		3672	stream_put_tv (s, BOP_INTEGER, iv);
		3673	}
		3674	return;
		3675
		3676	case T_SYMBOL:
		3677	if (0)
		3678	{
		3679	// no can do without more analysis
		3680	pointer m = lookup (SCHEME_A_ x);
		3681
		3682	if (is_proc (m))
		3683	{
		3684	printf ("compile proc %s %d\n", procname(m), procnum(m));
		3685	stream_put_tv (s, BOP_SYMBOL, BOP_OP + procnum (m));
		3686	}
		3687	else
		3688	stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
		3689	}
		3690
		3691	stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
		3692	return;
		3693
		3694	default:
		3695	stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
		3696	break;
		3697	}
		3698	}
		3699
		3700	ecb_cold static int
		3701	compile_closure (SCHEME_P_ pointer p)
		3702	{
		3703	stream s = stream_init ();
		3704
		3705	compile_list (SCHEME_A_ s, cdar (p));
		3706
		3707	FILE *xxd = popen ("xxd", "we");
		3708	fwrite (stream_data (s), 1, stream_size (s), xxd);
		3709	fclose (xxd);
		3710
		3711	return stream_size (s);
		3712	}
		3713
		3714	#endif
		3715
		3716	/* syntax, eval, core, ... */
		3717	ecb_hot static int
3334	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3718	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3335	{	3719	{
3336	pointer args = SCHEME_V->args;	3720	pointer args = SCHEME_V->args;
3337	pointer x, y;	3721	pointer x, y;
3338		3722
3339	switch (op)	3723	switch (op)
3340	{	3724	{
3341	#if EXPERIMENT //D	3725	#if EXPERIMENT //D
3342	case OP_DEBUG:	3726	case OP_DEBUG:
3343	printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);	3727	{
		3728	uint32_t len = compile_closure (SCHEME_A_ car (args));
		3729	printf ("len = %d\n", len);
3344	printf ("\n");	3730	printf ("\n");
3345	s_return (S_T);	3731	s_return (S_T);
		3732	}
		3733
		3734	case OP_DEBUG2:
		3735	return -1;
3346	#endif	3736	#endif
		3737
3347	case OP_LOAD: /* load */	3738	case OP_LOAD: /* load */
3348	if (file_interactive (SCHEME_A))	3739	if (file_interactive (SCHEME_A))
3349	{	3740	{
3350	xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");	3741	putstr (SCHEME_A_ "Loading ");
3351	//D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));	3742	putstr (SCHEME_A_ strvalue (car (args)));
		3743	putcharacter (SCHEME_A_ '\n');
3352	}	3744	}
3353		3745
3354	if (!file_push (SCHEME_A_ strvalue (car (args))))	3746	if (!file_push (SCHEME_A_ strvalue (car (args))))
3355	Error_1 ("unable to open", car (args));	3747	Error_1 ("unable to open", car (args));
3356	else	3748
3357	{
3358	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	3749	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3359	s_goto (OP_T0LVL);	3750	s_goto (OP_T0LVL);
3360	}
3361		3751
3362	case OP_T0LVL: /* top level */	3752	case OP_T0LVL: /* top level */
3363		3753
3364	/* If we reached the end of file, this loop is done. */	3754	/* If we reached the end of file, this loop is done. */
3365	if (SCHEME_V->loadport->object.port->kind & port_saw_EOF)	3755	if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3366	{	3756	{
3367	if (SCHEME_V->file_i == 0)	3757	if (SCHEME_V->file_i == 0)
3368	{	3758	{
3369	SCHEME_V->args = NIL;	3759	SCHEME_V->args = NIL;
3370	s_goto (OP_QUIT);	3760	s_goto (OP_QUIT);
…		…
3381	/* If interactive, be nice to user. */	3771	/* If interactive, be nice to user. */
3382	if (file_interactive (SCHEME_A))	3772	if (file_interactive (SCHEME_A))
3383	{	3773	{
3384	SCHEME_V->envir = SCHEME_V->global_env;	3774	SCHEME_V->envir = SCHEME_V->global_env;
3385	dump_stack_reset (SCHEME_A);	3775	dump_stack_reset (SCHEME_A);
3386	putstr (SCHEME_A_ "\n");	3776	putcharacter (SCHEME_A_ '\n');
		3777	#if EXPERIMENT
		3778	system ("ps v $PPID");
		3779	#endif
3387	putstr (SCHEME_A_ prompt);	3780	putstr (SCHEME_A_ prompt);
3388	}	3781	}
3389		3782
3390	/* Set up another iteration of REPL */	3783	/* Set up another iteration of REPL */
3391	SCHEME_V->nesting = 0;	3784	SCHEME_V->nesting = 0;
…		…
3426	{	3819	{
3427	SCHEME_V->print_flag = 1;	3820	SCHEME_V->print_flag = 1;
3428	SCHEME_V->args = SCHEME_V->value;	3821	SCHEME_V->args = SCHEME_V->value;
3429	s_goto (OP_P0LIST);	3822	s_goto (OP_P0LIST);
3430	}	3823	}
3431	else	3824
3432	s_return (SCHEME_V->value);	3825	s_return (SCHEME_V->value);
3433		3826
3434	case OP_EVAL: /* main part of evaluation */	3827	case OP_EVAL: /* main part of evaluation */
3435	#if USE_TRACING	3828	#if USE_TRACING
3436	if (SCHEME_V->tracing)	3829	if (SCHEME_V->tracing)
3437	{	3830	{
…		…
3448	#endif	3841	#endif
3449	if (is_symbol (SCHEME_V->code)) /* symbol */	3842	if (is_symbol (SCHEME_V->code)) /* symbol */
3450	{	3843	{
3451	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);	3844	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3452		3845
3453	if (x != NIL)	3846	if (x == NIL)
3454	s_return (slot_value_in_env (x));
3455	else
3456	Error_1 ("eval: unbound variable:", SCHEME_V->code);	3847	Error_1 ("eval: unbound variable:", SCHEME_V->code);
		3848
		3849	s_return (slot_value_in_env (x));
3457	}	3850	}
3458	else if (is_pair (SCHEME_V->code))	3851	else if (is_pair (SCHEME_V->code))
3459	{	3852	{
3460	x = car (SCHEME_V->code);	3853	x = car (SCHEME_V->code);
3461		3854
…		…
3470	/* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */	3863	/* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3471	SCHEME_V->code = x;	3864	SCHEME_V->code = x;
3472	s_goto (OP_EVAL);	3865	s_goto (OP_EVAL);
3473	}	3866	}
3474	}	3867	}
3475	else	3868
3476	s_return (SCHEME_V->code);	3869	s_return (SCHEME_V->code);
3477		3870
3478	case OP_E0ARGS: /* eval arguments */	3871	case OP_E0ARGS: /* eval arguments */
3479	if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */	3872	if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3480	{	3873	{
3481	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);	3874	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3482	SCHEME_V->args = cons (SCHEME_V->code, NIL);	3875	SCHEME_V->args = cons (SCHEME_V->code, NIL);
3483	SCHEME_V->code = SCHEME_V->value;	3876	SCHEME_V->code = SCHEME_V->value;
3484	s_goto (OP_APPLY);	3877	s_goto (OP_APPLY);
3485	}	3878	}
3486	else	3879
3487	{
3488	SCHEME_V->code = cdr (SCHEME_V->code);	3880	SCHEME_V->code = cdr (SCHEME_V->code);
3489	s_goto (OP_E1ARGS);	3881	s_goto (OP_E1ARGS);
3490	}
3491		3882
3492	case OP_E1ARGS: /* eval arguments */	3883	case OP_E1ARGS: /* eval arguments */
3493	args = cons (SCHEME_V->value, args);	3884	args = cons (SCHEME_V->value, args);
3494		3885
3495	if (is_pair (SCHEME_V->code)) /* continue */	3886	if (is_pair (SCHEME_V->code)) /* continue */
…		…
3506	SCHEME_V->args = cdr (args);	3897	SCHEME_V->args = cdr (args);
3507	s_goto (OP_APPLY);	3898	s_goto (OP_APPLY);
3508	}	3899	}
3509		3900
3510	#if USE_TRACING	3901	#if USE_TRACING
3511
3512	case OP_TRACING:	3902	case OP_TRACING:
3513	{	3903	{
3514	int tr = SCHEME_V->tracing;	3904	int tr = SCHEME_V->tracing;
3515		3905
3516	SCHEME_V->tracing = ivalue_unchecked (car (args));	3906	SCHEME_V->tracing = ivalue_unchecked (car (args));
3517	s_return (mk_integer (SCHEME_A_ tr));	3907	s_return (mk_integer (SCHEME_A_ tr));
3518	}	3908	}
3519
3520	#endif	3909	#endif
3521		3910
3522	case OP_APPLY: /* apply 'code' to 'args' */	3911	case OP_APPLY: /* apply 'code' to 'args' */
3523	#if USE_TRACING	3912	#if USE_TRACING
3524	if (SCHEME_V->tracing)	3913	if (SCHEME_V->tracing)
…		…
3538	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */	3927	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3539	else if (is_foreign (SCHEME_V->code))	3928	else if (is_foreign (SCHEME_V->code))
3540	{	3929	{
3541	/* Keep nested calls from GC'ing the arglist */	3930	/* Keep nested calls from GC'ing the arglist */
3542	push_recent_alloc (SCHEME_A_ args, NIL);	3931	push_recent_alloc (SCHEME_A_ args, NIL);
3543	x = SCHEME_V->code->object.ff (SCHEME_A_ args);	3932	x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3544		3933
3545	s_return (x);	3934	s_return (x);
3546	}	3935	}
3547	else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */	3936	else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3548	{	3937	{
…		…
3578	else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */	3967	else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3579	{	3968	{
3580	ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));	3969	ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3581	s_return (args != NIL ? car (args) : NIL);	3970	s_return (args != NIL ? car (args) : NIL);
3582	}	3971	}
3583	else	3972
3584	Error_0 ("illegal function");	3973	Error_0 ("illegal function");
3585		3974
3586	case OP_DOMACRO: /* do macro */	3975	case OP_DOMACRO: /* do macro */
3587	SCHEME_V->code = SCHEME_V->value;	3976	SCHEME_V->code = SCHEME_V->value;
3588	s_goto (OP_EVAL);	3977	s_goto (OP_EVAL);
3589		3978
…		…
3653	else	4042	else
3654	new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);	4043	new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3655		4044
3656	s_return (SCHEME_V->code);	4045	s_return (SCHEME_V->code);
3657		4046
3658
3659	case OP_DEFP: /* defined? */	4047	case OP_DEFP: /* defined? */
3660	x = SCHEME_V->envir;	4048	x = SCHEME_V->envir;
3661		4049
3662	if (cdr (args) != NIL)	4050	if (cdr (args) != NIL)
3663	x = cadr (args);	4051	x = cadr (args);
…		…
3681	s_return (SCHEME_V->value);	4069	s_return (SCHEME_V->value);
3682	}	4070	}
3683	else	4071	else
3684	Error_1 ("set!: unbound variable:", SCHEME_V->code);	4072	Error_1 ("set!: unbound variable:", SCHEME_V->code);
3685		4073
3686
3687	case OP_BEGIN: /* begin */	4074	case OP_BEGIN: /* begin */
3688	if (!is_pair (SCHEME_V->code))	4075	if (!is_pair (SCHEME_V->code))
3689	s_return (SCHEME_V->code);	4076	s_return (SCHEME_V->code);
3690		4077
3691	if (cdr (SCHEME_V->code) != NIL)	4078	if (cdr (SCHEME_V->code) != NIL)
…		…
3702	case OP_IF1: /* if */	4089	case OP_IF1: /* if */
3703	if (is_true (SCHEME_V->value))	4090	if (is_true (SCHEME_V->value))
3704	SCHEME_V->code = car (SCHEME_V->code);	4091	SCHEME_V->code = car (SCHEME_V->code);
3705	else	4092	else
3706	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */	4093	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
		4094
3707	s_goto (OP_EVAL);	4095	s_goto (OP_EVAL);
3708		4096
3709	case OP_LET0: /* let */	4097	case OP_LET0: /* let */
3710	SCHEME_V->args = NIL;	4098	SCHEME_V->args = NIL;
3711	SCHEME_V->value = SCHEME_V->code;	4099	SCHEME_V->value = SCHEME_V->code;
3712	SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);	4100	SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3713	s_goto (OP_LET1);	4101	s_goto (OP_LET1);
3714		4102
3715	case OP_LET1: /* let (calculate parameters) */	4103	case OP_LET1: /* let (calculate parameters) */
		4104	case OP_LET1REC: /* letrec (calculate parameters) */
3716	args = cons (SCHEME_V->value, args);	4105	args = cons (SCHEME_V->value, args);
3717		4106
3718	if (is_pair (SCHEME_V->code)) /* continue */	4107	if (is_pair (SCHEME_V->code)) /* continue */
3719	{	4108	{
3720	if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))	4109	if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3721	Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code));	4110	Error_1 ("Bad syntax of binding spec in let/letrec:", car (SCHEME_V->code));
3722		4111
3723	s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code));	4112	s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code));
3724	SCHEME_V->code = cadar (SCHEME_V->code);	4113	SCHEME_V->code = cadar (SCHEME_V->code);
3725	SCHEME_V->args = NIL;	4114	SCHEME_V->args = NIL;
3726	s_goto (OP_EVAL);	4115	s_goto (OP_EVAL);
3727	}	4116	}
3728	else /* end */	4117
3729	{	4118	/* end */
3730	args = reverse_in_place (SCHEME_A_ NIL, args);	4119	args = reverse_in_place (SCHEME_A_ NIL, args);
3731	SCHEME_V->code = car (args);	4120	SCHEME_V->code = car (args);
3732	SCHEME_V->args = cdr (args);	4121	SCHEME_V->args = cdr (args);
3733	s_goto (OP_LET2);	4122	s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC);
3734	}
3735		4123
3736	case OP_LET2: /* let */	4124	case OP_LET2: /* let */
3737	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);	4125	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3738		4126
3739	for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;	4127	for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
…		…
3743	if (is_symbol (car (SCHEME_V->code))) /* named let */	4131	if (is_symbol (car (SCHEME_V->code))) /* named let */
3744	{	4132	{
3745	for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))	4133	for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3746	{	4134	{
3747	if (!is_pair (x))	4135	if (!is_pair (x))
3748	Error_1 ("Bad syntax of binding in let :", x);	4136	Error_1 ("Bad syntax of binding in let:", x);
3749		4137
3750	if (!is_list (SCHEME_A_ car (x)))	4138	if (!is_list (SCHEME_A_ car (x)))
3751	Error_1 ("Bad syntax of binding in let :", car (x));	4139	Error_1 ("Bad syntax of binding in let:", car (x));
3752		4140
3753	args = cons (caar (x), args);	4141	args = cons (caar (x), args);
3754	}	4142	}
3755		4143
3756	x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),	4144	x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
…		…
3773	SCHEME_V->code = cdr (SCHEME_V->code);	4161	SCHEME_V->code = cdr (SCHEME_V->code);
3774	s_goto (OP_BEGIN);	4162	s_goto (OP_BEGIN);
3775	}	4163	}
3776		4164
3777	if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code)))	4165	if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code)))
3778	Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code));	4166	Error_1 ("Bad syntax of binding spec in let*:", car (SCHEME_V->code));
3779		4167
3780	s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));	4168	s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
3781	SCHEME_V->code = car (cdaar (SCHEME_V->code));	4169	SCHEME_V->code = car (cdaar (SCHEME_V->code));
3782	s_goto (OP_EVAL);	4170	s_goto (OP_EVAL);
3783		4171
…		…
3794	s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);	4182	s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3795	SCHEME_V->code = cadar (SCHEME_V->code);	4183	SCHEME_V->code = cadar (SCHEME_V->code);
3796	SCHEME_V->args = NIL;	4184	SCHEME_V->args = NIL;
3797	s_goto (OP_EVAL);	4185	s_goto (OP_EVAL);
3798	}	4186	}
3799	else /* end */	4187
		4188	/* end */
3800	{	4189
3801	SCHEME_V->code = args;	4190	SCHEME_V->code = args;
3802	SCHEME_V->args = NIL;	4191	SCHEME_V->args = NIL;
3803	s_goto (OP_BEGIN);	4192	s_goto (OP_BEGIN);
3804	}
3805		4193
3806	case OP_LET0REC: /* letrec */	4194	case OP_LET0REC: /* letrec */
3807	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);	4195	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3808	SCHEME_V->args = NIL;	4196	SCHEME_V->args = NIL;
3809	SCHEME_V->value = SCHEME_V->code;	4197	SCHEME_V->value = SCHEME_V->code;
3810	SCHEME_V->code = car (SCHEME_V->code);	4198	SCHEME_V->code = car (SCHEME_V->code);
3811	s_goto (OP_LET1REC);	4199	s_goto (OP_LET1REC);
3812		4200
3813	case OP_LET1REC: /* letrec (calculate parameters) */	4201	/* OP_LET1REC handled by OP_LET1 */
3814	args = cons (SCHEME_V->value, args);
3815
3816	if (is_pair (SCHEME_V->code)) /* continue */
3817	{
3818	if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3819	Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3820
3821	s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3822	SCHEME_V->code = cadar (SCHEME_V->code);
3823	SCHEME_V->args = NIL;
3824	s_goto (OP_EVAL);
3825	}
3826	else /* end */
3827	{
3828	args = reverse_in_place (SCHEME_A_ NIL, args);
3829	SCHEME_V->code = car (args);
3830	SCHEME_V->args = cdr (args);
3831	s_goto (OP_LET2REC);
3832	}
3833		4202
3834	case OP_LET2REC: /* letrec */	4203	case OP_LET2REC: /* letrec */
3835	for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))	4204	for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3836	new_slot_in_env (SCHEME_A_ caar (x), car (y));	4205	new_slot_in_env (SCHEME_A_ caar (x), car (y));
3837		4206
…		…
3867	}	4236	}
3868	else	4237	else
3869	{	4238	{
3870	if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)	4239	if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3871	s_return (NIL);	4240	s_return (NIL);
3872	else	4241
3873	{
3874	s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);	4242	s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3875	SCHEME_V->code = caar (SCHEME_V->code);	4243	SCHEME_V->code = caar (SCHEME_V->code);
3876	s_goto (OP_EVAL);	4244	s_goto (OP_EVAL);
3877	}
3878	}	4245	}
3879		4246
3880	case OP_DELAY: /* delay */	4247	case OP_DELAY: /* delay */
3881	x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);	4248	x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3882	set_typeflag (x, T_PROMISE);	4249	set_typeflag (x, T_PROMISE);
…		…
3893	case OP_AND1: /* and */	4260	case OP_AND1: /* and */
3894	if (is_false (SCHEME_V->value))	4261	if (is_false (SCHEME_V->value))
3895	s_return (SCHEME_V->value);	4262	s_return (SCHEME_V->value);
3896	else if (SCHEME_V->code == NIL)	4263	else if (SCHEME_V->code == NIL)
3897	s_return (SCHEME_V->value);	4264	s_return (SCHEME_V->value);
3898	else	4265
3899	{
3900	s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));	4266	s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3901	SCHEME_V->code = car (SCHEME_V->code);	4267	SCHEME_V->code = car (SCHEME_V->code);
3902	s_goto (OP_EVAL);	4268	s_goto (OP_EVAL);
3903	}
3904		4269
3905	case OP_OR0: /* or */	4270	case OP_OR0: /* or */
3906	if (SCHEME_V->code == NIL)	4271	if (SCHEME_V->code == NIL)
3907	s_return (S_F);	4272	s_return (S_F);
3908		4273
…		…
3913	case OP_OR1: /* or */	4278	case OP_OR1: /* or */
3914	if (is_true (SCHEME_V->value))	4279	if (is_true (SCHEME_V->value))
3915	s_return (SCHEME_V->value);	4280	s_return (SCHEME_V->value);
3916	else if (SCHEME_V->code == NIL)	4281	else if (SCHEME_V->code == NIL)
3917	s_return (SCHEME_V->value);	4282	s_return (SCHEME_V->value);
3918	else	4283
3919	{
3920	s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));	4284	s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3921	SCHEME_V->code = car (SCHEME_V->code);	4285	SCHEME_V->code = car (SCHEME_V->code);
3922	s_goto (OP_EVAL);	4286	s_goto (OP_EVAL);
3923	}
3924		4287
3925	case OP_C0STREAM: /* cons-stream */	4288	case OP_C0STREAM: /* cons-stream */
3926	s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));	4289	s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3927	SCHEME_V->code = car (SCHEME_V->code);	4290	SCHEME_V->code = car (SCHEME_V->code);
3928	s_goto (OP_EVAL);	4291	s_goto (OP_EVAL);
…		…
3993	s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));	4356	s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3994	SCHEME_V->code = caar (x);	4357	SCHEME_V->code = caar (x);
3995	s_goto (OP_EVAL);	4358	s_goto (OP_EVAL);
3996	}	4359	}
3997	}	4360	}
3998	else	4361
3999	s_return (NIL);	4362	s_return (NIL);
4000		4363
4001	case OP_CASE2: /* case */	4364	case OP_CASE2: /* case */
4002	if (is_true (SCHEME_V->value))	4365	if (is_true (SCHEME_V->value))
4003	s_goto (OP_BEGIN);	4366	s_goto (OP_BEGIN);
4004	else	4367
4005	s_return (NIL);	4368	s_return (NIL);
4006		4369
4007	case OP_PAPPLY: /* apply */	4370	case OP_PAPPLY: /* apply */
4008	SCHEME_V->code = car (args);	4371	SCHEME_V->code = car (args);
4009	SCHEME_V->args = list_star (SCHEME_A_ cdr (args));	4372	SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
4010	/*SCHEME_V->args = cadr(args); */	4373	/*SCHEME_V->args = cadr(args); */
…		…
4024	}	4387	}
4025		4388
4026	if (USE_ERROR_CHECKING) abort ();	4389	if (USE_ERROR_CHECKING) abort ();
4027	}	4390	}
4028		4391
4029	static int	4392	/* math, cxr */
		4393	ecb_hot static int
4030	opexe_1 (SCHEME_P_ enum scheme_opcodes op)	4394	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
4031	{	4395	{
4032	pointer args = SCHEME_V->args;	4396	pointer args = SCHEME_V->args;
4033	pointer x = car (args);	4397	pointer x = car (args);
4034	num v;	4398	num v;
4035		4399
4036	switch (op)	4400	switch (op)
4037	{	4401	{
4038	#if USE_MATH	4402	#if USE_MATH
4039	case OP_INEX2EX: /* inexact->exact */	4403	case OP_INEX2EX: /* inexact->exact */
4040	{
4041	if (is_integer (x))	4404	if (!is_integer (x))
4042	s_return (x);	4405	{
4043
4044	RVALUE r = rvalue_unchecked (x);	4406	RVALUE r = rvalue_unchecked (x);
4045		4407
4046	if (r == (RVALUE)(IVALUE)r)	4408	if (r == (RVALUE)(IVALUE)r)
4047	s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x)));	4409	x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4048	else	4410	else
4049	Error_1 ("inexact->exact: not integral:", x);	4411	Error_1 ("inexact->exact: not integral:", x);
4050	}	4412	}
4051		4413
		4414	s_return (x);
		4415
		4416	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
		4417	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
		4418	case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
		4419	case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
		4420
		4421	case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4052	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));	4422	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4053	case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))));	4423	case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
		4424	/ (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4054	case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));	4425	case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4055	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));	4426	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4056	case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));	4427	case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4057	case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));	4428	case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4058	case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));	4429	case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4059		4430
4060	case OP_ATAN:	4431	case OP_ATAN:
		4432	s_return (mk_real (SCHEME_A_
4061	if (cdr (args) == NIL)	4433	cdr (args) == NIL
4062	s_return (mk_real (SCHEME_A_ atan (rvalue (x))));	4434	? atan (rvalue (x))
4063	else	4435	: atan2 (rvalue (x), rvalue (cadr (args)))));
4064	{
4065	pointer y = cadr (args);
4066	s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4067	}
4068
4069	case OP_SQRT:
4070	s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4071		4436
4072	case OP_EXPT:	4437	case OP_EXPT:
4073	{	4438	{
4074	RVALUE result;	4439	RVALUE result;
4075	int real_result = 1;	4440	int real_result = 1;
…		…
4098	if (real_result)	4463	if (real_result)
4099	s_return (mk_real (SCHEME_A_ result));	4464	s_return (mk_real (SCHEME_A_ result));
4100	else	4465	else
4101	s_return (mk_integer (SCHEME_A_ result));	4466	s_return (mk_integer (SCHEME_A_ result));
4102	}	4467	}
4103
4104	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4105	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4106
4107	case OP_TRUNCATE:
4108	{
4109	RVALUE n = rvalue (x);
4110	s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4111	}
4112
4113	case OP_ROUND:
4114	if (is_integer (x))
4115	s_return (x);
4116
4117	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4118	#endif	4468	#endif
4119		4469
4120	case OP_ADD: /* + */	4470	case OP_ADD: /* + */
4121	v = num_zero;	4471	v = num_zero;
4122		4472
…		…
4424	memcpy (pos, strvalue (car (x)), strlength (car (x)));	4774	memcpy (pos, strvalue (car (x)), strlength (car (x)));
4425		4775
4426	s_return (newstr);	4776	s_return (newstr);
4427	}	4777	}
4428		4778
4429	case OP_SUBSTR: /* substring */	4779	case OP_STRING_COPY: /* substring/string-copy */
4430	{	4780	{
4431	char *str = strvalue (x);	4781	char *str = strvalue (x);
4432	int index0 = ivalue_unchecked (cadr (args));	4782	int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4433	int index1;	4783	int index1;
4434	int len;	4784	int len;
4435		4785
4436	if (index0 > strlength (x))	4786	if (index0 > strlength (x))
4437	Error_1 ("substring: start out of bounds:", cadr (args));	4787	Error_1 ("string->copy: start out of bounds:", cadr (args));
4438		4788
4439	if (cddr (args) != NIL)	4789	if (cddr (args) != NIL)
4440	{	4790	{
4441	index1 = ivalue_unchecked (caddr (args));	4791	index1 = ivalue_unchecked (caddr (args));
4442		4792
4443	if (index1 > strlength (x) || index1 < index0)	4793	if (index1 > strlength (x) || index1 < index0)
4444	Error_1 ("substring: end out of bounds:", caddr (args));	4794	Error_1 ("string->copy: end out of bounds:", caddr (args));
4445	}	4795	}
4446	else	4796	else
4447	index1 = strlength (x);	4797	index1 = strlength (x);
4448		4798
4449	len = index1 - index0;	4799	len = index1 - index0;
4450	x = mk_empty_string (SCHEME_A_ len, ' ');	4800	x = mk_counted_string (SCHEME_A_ str + index0, len);
4451	memcpy (strvalue (x), str + index0, len);
4452	strvalue (x)[len] = 0;
4453		4801
4454	s_return (x);	4802	s_return (x);
4455	}	4803	}
4456		4804
4457	case OP_VECTOR: /* vector */	4805	case OP_VECTOR: /* vector */
…		…
4531	}	4879	}
4532		4880
4533	if (USE_ERROR_CHECKING) abort ();	4881	if (USE_ERROR_CHECKING) abort ();
4534	}	4882	}
4535		4883
4536	static int	4884	/* relational ops */
		4885	ecb_hot static int
4537	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	4886	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4538	{	4887	{
4539	pointer x = SCHEME_V->args;	4888	pointer x = SCHEME_V->args;
4540		4889
4541	for (;;)	4890	for (;;)
…		…
4562	}	4911	}
4563		4912
4564	s_return (S_T);	4913	s_return (S_T);
4565	}	4914	}
4566		4915
4567	static int	4916	/* predicates */
		4917	ecb_hot static int
4568	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4918	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4569	{	4919	{
4570	pointer args = SCHEME_V->args;	4920	pointer args = SCHEME_V->args;
4571	pointer a = car (args);	4921	pointer a = car (args);
4572	pointer d = cdr (args);	4922	pointer d = cdr (args);
…		…
4619	}	4969	}
4620		4970
4621	s_retbool (r);	4971	s_retbool (r);
4622	}	4972	}
4623		4973
4624	static int	4974	/* promises, list ops, ports */
		4975	ecb_hot static int
4625	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4976	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4626	{	4977	{
4627	pointer args = SCHEME_V->args;	4978	pointer args = SCHEME_V->args;
4628	pointer a = car (args);	4979	pointer a = car (args);
4629	pointer x, y;	4980	pointer x, y;
…		…
4642	}	4993	}
4643	else	4994	else
4644	s_return (SCHEME_V->code);	4995	s_return (SCHEME_V->code);
4645		4996
4646	case OP_SAVE_FORCED: /* Save forced value replacing promise */	4997	case OP_SAVE_FORCED: /* Save forced value replacing promise */
4647	memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell));	4998	*CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4648	s_return (SCHEME_V->value);	4999	s_return (SCHEME_V->value);
4649		5000
4650	#if USE_PORTS	5001	#if USE_PORTS
		5002
		5003	case OP_EOF_OBJECT: /* eof-object */
		5004	s_return (S_EOF);
4651		5005
4652	case OP_WRITE: /* write */	5006	case OP_WRITE: /* write */
4653	case OP_DISPLAY: /* display */	5007	case OP_DISPLAY: /* display */
4654	case OP_WRITE_CHAR: /* write-char */	5008	case OP_WRITE_CHAR: /* write-char */
4655	if (is_pair (cdr (SCHEME_V->args)))	5009	if (is_pair (cdr (SCHEME_V->args)))
…		…
4669	else	5023	else
4670	SCHEME_V->print_flag = 0;	5024	SCHEME_V->print_flag = 0;
4671		5025
4672	s_goto (OP_P0LIST);	5026	s_goto (OP_P0LIST);
4673		5027
		5028	//TODO: move to scheme
4674	case OP_NEWLINE: /* newline */	5029	case OP_NEWLINE: /* newline */
4675	if (is_pair (args))	5030	if (is_pair (args))
4676	{	5031	{
4677	if (a != SCHEME_V->outport)	5032	if (a != SCHEME_V->outport)
4678	{	5033	{
…		…
4680	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);	5035	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4681	SCHEME_V->outport = a;	5036	SCHEME_V->outport = a;
4682	}	5037	}
4683	}	5038	}
4684		5039
4685	putstr (SCHEME_A_ "\n");	5040	putcharacter (SCHEME_A_ '\n');
4686	s_return (S_T);	5041	s_return (S_T);
4687	#endif	5042	#endif
4688		5043
4689	case OP_ERR0: /* error */	5044	case OP_ERR0: /* error */
4690	SCHEME_V->retcode = -1;	5045	SCHEME_V->retcode = -1;
…		…
4699	putstr (SCHEME_A_ strvalue (car (args)));	5054	putstr (SCHEME_A_ strvalue (car (args)));
4700	SCHEME_V->args = cdr (args);	5055	SCHEME_V->args = cdr (args);
4701	s_goto (OP_ERR1);	5056	s_goto (OP_ERR1);
4702		5057
4703	case OP_ERR1: /* error */	5058	case OP_ERR1: /* error */
4704	putstr (SCHEME_A_ " ");	5059	putcharacter (SCHEME_A_ ' ');
4705		5060
4706	if (args != NIL)	5061	if (args != NIL)
4707	{	5062	{
4708	s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);	5063	s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4709	SCHEME_V->args = a;	5064	SCHEME_V->args = a;
4710	SCHEME_V->print_flag = 1;	5065	SCHEME_V->print_flag = 1;
4711	s_goto (OP_P0LIST);	5066	s_goto (OP_P0LIST);
4712	}	5067	}
4713	else	5068	else
4714	{	5069	{
4715	putstr (SCHEME_A_ "\n");	5070	putcharacter (SCHEME_A_ '\n');
4716		5071
4717	if (SCHEME_V->interactive_repl)	5072	if (SCHEME_V->interactive_repl)
4718	s_goto (OP_T0LVL);	5073	s_goto (OP_T0LVL);
4719	else	5074	else
4720	return -1;	5075	return -1;
…		…
4797	SCHEME_V->gc_verbose = (a != S_F);	5152	SCHEME_V->gc_verbose = (a != S_F);
4798	s_retbool (was);	5153	s_retbool (was);
4799	}	5154	}
4800		5155
4801	case OP_NEWSEGMENT: /* new-segment */	5156	case OP_NEWSEGMENT: /* new-segment */
		5157	#if 0
4802	if (!is_pair (args) || !is_number (a))	5158	if (!is_pair (args) || !is_number (a))
4803	Error_0 ("new-segment: argument must be a number");	5159	Error_0 ("new-segment: argument must be a number");
4804		5160	#endif
4805	alloc_cellseg (SCHEME_A_ ivalue (a));	5161	s_retbool (alloc_cellseg (SCHEME_A));
4806
4807	s_return (S_T);
4808		5162
4809	case OP_OBLIST: /* oblist */	5163	case OP_OBLIST: /* oblist */
4810	s_return (oblist_all_symbols (SCHEME_A));	5164	s_return (oblist_all_symbols (SCHEME_A));
4811		5165
4812	#if USE_PORTS	5166	#if USE_PORTS
…		…
4882	s_return (p == NIL ? S_F : p);	5236	s_return (p == NIL ? S_F : p);
4883	}	5237	}
4884		5238
4885	case OP_GET_OUTSTRING: /* get-output-string */	5239	case OP_GET_OUTSTRING: /* get-output-string */
4886	{	5240	{
4887	port *p;	5241	port *p = port (a);
4888		5242
4889	if ((p = a->object.port)->kind & port_string)	5243	if (p->kind & port_string)
4890	{	5244	{
4891	off_t size;	5245	off_t size;
4892	char *str;	5246	char *str;
4893		5247
4894	size = p->rep.string.curr - p->rep.string.start + 1;	5248	size = p->rep.string.curr - p->rep.string.start + 1;
…		…
4929	}	5283	}
4930		5284
4931	if (USE_ERROR_CHECKING) abort ();	5285	if (USE_ERROR_CHECKING) abort ();
4932	}	5286	}
4933		5287
4934	static int	5288	/* reading */
		5289	ecb_cold static int
4935	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	5290	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4936	{	5291	{
4937	pointer args = SCHEME_V->args;	5292	pointer args = SCHEME_V->args;
4938	pointer x;	5293	pointer x;
4939		5294
…		…
4999	int res;	5354	int res;
5000		5355
5001	if (is_pair (args))	5356	if (is_pair (args))
5002	p = car (args);	5357	p = car (args);
5003		5358
5004	res = p->object.port->kind & port_string;	5359	res = port (p)->kind & port_string;
5005		5360
5006	s_retbool (res);	5361	s_retbool (res);
5007	}	5362	}
5008		5363
5009	case OP_SET_INPORT: /* set-input-port */	5364	case OP_SET_INPORT: /* set-input-port */
…		…
5018	case OP_RDSEXPR:	5373	case OP_RDSEXPR:
5019	switch (SCHEME_V->tok)	5374	switch (SCHEME_V->tok)
5020	{	5375	{
5021	case TOK_EOF:	5376	case TOK_EOF:
5022	s_return (S_EOF);	5377	s_return (S_EOF);
5023	/* NOTREACHED */
5024		5378
5025	case TOK_VEC:	5379	case TOK_VEC:
5026	s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);	5380	s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
5027	/* fall through */	5381	/* fall through */
5028		5382
…		…
5031		5385
5032	if (SCHEME_V->tok == TOK_RPAREN)	5386	if (SCHEME_V->tok == TOK_RPAREN)
5033	s_return (NIL);	5387	s_return (NIL);
5034	else if (SCHEME_V->tok == TOK_DOT)	5388	else if (SCHEME_V->tok == TOK_DOT)
5035	Error_0 ("syntax error: illegal dot expression");	5389	Error_0 ("syntax error: illegal dot expression");
5036	else	5390
5037	{
5038	SCHEME_V->nesting_stack[SCHEME_V->file_i]++;	5391	SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
5039	s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);	5392	s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
5040	s_goto (OP_RDSEXPR);	5393	s_goto (OP_RDSEXPR);
5041	}
5042		5394
5043	case TOK_QUOTE:	5395	case TOK_QUOTE:
5044	s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);	5396	s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
5045	SCHEME_V->tok = token (SCHEME_A);	5397	SCHEME_V->tok = token (SCHEME_A);
5046	s_goto (OP_RDSEXPR);	5398	s_goto (OP_RDSEXPR);
…		…
5052	{	5404	{
5053	s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);	5405	s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5054	SCHEME_V->tok = TOK_LPAREN;	5406	SCHEME_V->tok = TOK_LPAREN;
5055	s_goto (OP_RDSEXPR);	5407	s_goto (OP_RDSEXPR);
5056	}	5408	}
5057	else	5409
5058	s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);	5410	s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5059
5060	s_goto (OP_RDSEXPR);	5411	s_goto (OP_RDSEXPR);
5061		5412
5062	case TOK_COMMA:	5413	case TOK_COMMA:
5063	s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);	5414	s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
5064	SCHEME_V->tok = token (SCHEME_A);	5415	SCHEME_V->tok = token (SCHEME_A);
…		…
5075	case TOK_DOTATOM:	5426	case TOK_DOTATOM:
5076	SCHEME_V->strbuff[0] = '.';	5427	SCHEME_V->strbuff[0] = '.';
5077	s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));	5428	s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5078		5429
5079	case TOK_STRATOM:	5430	case TOK_STRATOM:
		5431	//TODO: haven't checked whether the garbage collector could interfere and free x
		5432	gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded
5080	x = readstrexp (SCHEME_A_ '|');	5433	x = readstrexp (SCHEME_A_ '|');
5081	//TODO: haven't checked whether the garbage collector could interfere
5082	s_return (mk_atom (SCHEME_A_ strvalue (x)));	5434	s_return (mk_atom (SCHEME_A_ strvalue (x)));
5083		5435
5084	case TOK_DQUOTE:	5436	case TOK_DQUOTE:
5085	x = readstrexp (SCHEME_A_ '"');	5437	x = readstrexp (SCHEME_A_ '"');
5086		5438
…		…
5094	{	5446	{
5095	pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);	5447	pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);
5096		5448
5097	if (f == NIL)	5449	if (f == NIL)
5098	Error_0 ("undefined sharp expression");	5450	Error_0 ("undefined sharp expression");
5099	else	5451
5100	{
5101	SCHEME_V->code = cons (slot_value_in_env (f), NIL);	5452	SCHEME_V->code = cons (slot_value_in_env (f), NIL);
5102	s_goto (OP_EVAL);	5453	s_goto (OP_EVAL);
5103	}
5104	}	5454	}
5105		5455
5106	case TOK_SHARP_CONST:	5456	case TOK_SHARP_CONST:
5107	if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)	5457	if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5108	Error_0 ("undefined sharp expression");	5458	Error_0 ("undefined sharp expression");
5109	else	5459
5110	s_return (x);	5460	s_return (x);
5111		5461
5112	default:	5462	default:
5113	Error_0 ("syntax error: illegal token");	5463	Error_0 ("syntax error: illegal token");
5114	}	5464	}
5115		5465
…		…
5208	pointer b = cdr (args);	5558	pointer b = cdr (args);
5209	int ok_abbr = ok_abbrev (b);	5559	int ok_abbr = ok_abbrev (b);
5210	SCHEME_V->args = car (b);	5560	SCHEME_V->args = car (b);
5211		5561
5212	if (a == SCHEME_V->QUOTE && ok_abbr)	5562	if (a == SCHEME_V->QUOTE && ok_abbr)
5213	putstr (SCHEME_A_ "'");	5563	putcharacter (SCHEME_A_ '\'');
5214	else if (a == SCHEME_V->QQUOTE && ok_abbr)	5564	else if (a == SCHEME_V->QQUOTE && ok_abbr)
5215	putstr (SCHEME_A_ "`");	5565	putcharacter (SCHEME_A_ '`');
5216	else if (a == SCHEME_V->UNQUOTE && ok_abbr)	5566	else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5217	putstr (SCHEME_A_ ",");	5567	putcharacter (SCHEME_A_ ',');
5218	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)	5568	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5219	putstr (SCHEME_A_ ",@");	5569	putstr (SCHEME_A_ ",@");
5220	else	5570	else
5221	{	5571	{
5222	putstr (SCHEME_A_ "(");	5572	putcharacter (SCHEME_A_ '(');
5223	s_save (SCHEME_A_ OP_P1LIST, b, NIL);	5573	s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5224	SCHEME_V->args = a;	5574	SCHEME_V->args = a;
5225	}	5575	}
5226		5576
5227	s_goto (OP_P0LIST);	5577	s_goto (OP_P0LIST);
…		…
5229		5579
5230	case OP_P1LIST:	5580	case OP_P1LIST:
5231	if (is_pair (args))	5581	if (is_pair (args))
5232	{	5582	{
5233	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);	5583	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5234	putstr (SCHEME_A_ " ");	5584	putcharacter (SCHEME_A_ ' ');
5235	SCHEME_V->args = car (args);	5585	SCHEME_V->args = car (args);
5236	s_goto (OP_P0LIST);	5586	s_goto (OP_P0LIST);
5237	}	5587	}
5238	else if (is_vector (args))	5588	else if (is_vector (args))
5239	{	5589	{
…		…
5247	{	5597	{
5248	putstr (SCHEME_A_ " . ");	5598	putstr (SCHEME_A_ " . ");
5249	printatom (SCHEME_A_ args, SCHEME_V->print_flag);	5599	printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5250	}	5600	}
5251		5601
5252	putstr (SCHEME_A_ ")");	5602	putcharacter (SCHEME_A_ ')');
5253	s_return (S_T);	5603	s_return (S_T);
5254	}	5604	}
5255		5605
5256	case OP_PVECFROM:	5606	case OP_PVECFROM:
5257	{	5607	{
5258	int i = ivalue_unchecked (cdr (args));	5608	IVALUE i = ivalue_unchecked (cdr (args));
5259	pointer vec = car (args);	5609	pointer vec = car (args);
5260	int len = veclength (vec);	5610	uint32_t len = veclength (vec);
5261		5611
5262	if (i == len)	5612	if (i == len)
5263	{	5613	{
5264	putstr (SCHEME_A_ ")");	5614	putcharacter (SCHEME_A_ ')');
5265	s_return (S_T);	5615	s_return (S_T);
5266	}	5616	}
5267	else	5617	else
5268	{	5618	{
5269	pointer elem = vector_get (vec, i);	5619	pointer elem = vector_get (vec, i);
5270		5620
5271	ivalue_unchecked (cdr (args)) = i + 1;	5621	set_cdr (args, mk_integer (SCHEME_A_ i + 1));
5272	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);	5622	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5273	SCHEME_V->args = elem;	5623	SCHEME_V->args = elem;
5274		5624
5275	if (i > 0)	5625	if (i > 0)
5276	putstr (SCHEME_A_ " ");	5626	putcharacter (SCHEME_A_ ' ');
5277		5627
5278	s_goto (OP_P0LIST);	5628	s_goto (OP_P0LIST);
5279	}	5629	}
5280	}	5630	}
5281	}	5631	}
5282		5632
5283	if (USE_ERROR_CHECKING) abort ();	5633	if (USE_ERROR_CHECKING) abort ();
5284	}	5634	}
5285		5635
5286	static int	5636	/* list ops */
		5637	ecb_hot static int
5287	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5638	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5288	{	5639	{
5289	pointer args = SCHEME_V->args;	5640	pointer args = SCHEME_V->args;
5290	pointer a = car (args);	5641	pointer a = car (args);
5291	pointer x, y;	5642	pointer x, y;
…		…
5314	break;	5665	break;
5315	}	5666	}
5316		5667
5317	if (is_pair (y))	5668	if (is_pair (y))
5318	s_return (car (y));	5669	s_return (car (y));
5319	else	5670
5320	s_return (S_F);	5671	s_return (S_F);
5321
5322		5672
5323	case OP_GET_CLOSURE: /* get-closure-code *//* a.k */	5673	case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5324	SCHEME_V->args = a;	5674	SCHEME_V->args = a;
5325		5675
5326	if (SCHEME_V->args == NIL)	5676	if (SCHEME_V->args == NIL)
5327	s_return (S_F);	5677	s_return (S_F);
5328	else if (is_closure (SCHEME_V->args))	5678	else if (is_closure (SCHEME_V->args) || is_macro (SCHEME_V->args))
5329	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));	5679	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5330	else if (is_macro (SCHEME_V->args))	5680
5331	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5332	else
5333	s_return (S_F);	5681	s_return (S_F);
5334		5682
5335	case OP_CLOSUREP: /* closure? */	5683	case OP_CLOSUREP: /* closure? */
5336	/*	5684	/*
5337	* Note, macro object is also a closure.	5685	* Note, macro object is also a closure.
5338	* Therefore, (closure? <#MACRO>) ==> #t	5686	* Therefore, (closure? <#MACRO>) ==> #t
…		…
5349		5697
5350	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */	5698	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5351	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);	5699	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5352		5700
5353	typedef int (*test_predicate)(pointer);	5701	typedef int (*test_predicate)(pointer);
5354	static int	5702
		5703	ecb_hot static int
5355	tst_any (pointer p)	5704	tst_any (pointer p)
5356	{	5705	{
5357	return 1;	5706	return 1;
5358	}	5707	}
5359		5708
5360	static int	5709	ecb_hot static int
5361	tst_inonneg (pointer p)	5710	tst_inonneg (pointer p)
5362	{	5711	{
5363	return is_integer (p) && ivalue_unchecked (p) >= 0;	5712	return is_integer (p) && ivalue_unchecked (p) >= 0;
5364	}	5713	}
5365		5714
5366	static int	5715	ecb_hot static int
5367	tst_is_list (SCHEME_P_ pointer p)	5716	tst_is_list (SCHEME_P_ pointer p)
5368	{	5717	{
5369	return p == NIL || is_pair (p);	5718	return p == NIL || is_pair (p);
5370	}	5719	}
5371		5720
…		…
5414	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"	5763	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5415	#include "opdefines.h"	5764	#include "opdefines.h"
5416	#undef OP_DEF	5765	#undef OP_DEF
5417	;	5766	;
5418		5767
5419	static const char *	5768	ecb_cold static const char *
5420	opname (int idx)	5769	opname (int idx)
5421	{	5770	{
5422	const char *name = opnames;	5771	const char *name = opnames;
5423		5772
5424	/* should do this at compile time, but would require external program, right? */	5773	/* should do this at compile time, but would require external program, right? */
…		…
5426	name += strlen (name) + 1;	5775	name += strlen (name) + 1;
5427		5776
5428	return *name ? name : "ILLEGAL";	5777	return *name ? name : "ILLEGAL";
5429	}	5778	}
5430		5779
5431	static const char *	5780	ecb_cold static const char *
5432	procname (pointer x)	5781	procname (pointer x)
5433	{	5782	{
5434	return opname (procnum (x));	5783	return opname (procnum (x));
5435	}	5784	}
5436		5785
…		…
5456	#undef OP_DEF	5805	#undef OP_DEF
5457	{0}	5806	{0}
5458	};	5807	};
5459		5808
5460	/* kernel of this interpreter */	5809	/* kernel of this interpreter */
5461	static void ecb_hot	5810	ecb_hot static void
5462	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5811	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5463	{	5812	{
5464	SCHEME_V->op = op;	5813	SCHEME_V->op = op;
5465		5814
5466	for (;;)	5815	for (;;)
…		…
5549	if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))	5898	if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5550	return;	5899	return;
5551		5900
5552	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	5901	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5553	{	5902	{
5554	xwrstr ("No memory!\n");	5903	putstr (SCHEME_A_ "No memory!\n");
5555	return;	5904	return;
5556	}	5905	}
5557	}	5906	}
5558	}	5907	}
5559		5908
5560	/* ========== Initialization of internal keywords ========== */	5909	/* ========== Initialization of internal keywords ========== */
5561		5910
5562	static void	5911	ecb_cold static void
5563	assign_syntax (SCHEME_P_ const char *name)	5912	assign_syntax (SCHEME_P_ const char *name)
5564	{	5913	{
5565	pointer x = oblist_add_by_name (SCHEME_A_ name);	5914	pointer x = oblist_add_by_name (SCHEME_A_ name);
5566	set_typeflag (x, typeflag (x) | T_SYNTAX);	5915	set_typeflag (x, typeflag (x) | T_SYNTAX);
5567	}	5916	}
5568		5917
5569	static void	5918	ecb_cold static void
5570	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)	5919	assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5571	{	5920	{
5572	pointer x = mk_symbol (SCHEME_A_ name);	5921	pointer x = mk_symbol (SCHEME_A_ name);
5573	pointer y = mk_proc (SCHEME_A_ op);	5922	pointer y = mk_proc (SCHEME_A_ op);
5574	new_slot_in_env (SCHEME_A_ x, y);	5923	new_slot_in_env (SCHEME_A_ x, y);
…		…
5577	static pointer	5926	static pointer
5578	mk_proc (SCHEME_P_ enum scheme_opcodes op)	5927	mk_proc (SCHEME_P_ enum scheme_opcodes op)
5579	{	5928	{
5580	pointer y = get_cell (SCHEME_A_ NIL, NIL);	5929	pointer y = get_cell (SCHEME_A_ NIL, NIL);
5581	set_typeflag (y, (T_PROC | T_ATOM));	5930	set_typeflag (y, (T_PROC | T_ATOM));
5582	ivalue_unchecked (y) = op;	5931	set_ivalue (y, op);
5583	return y;	5932	return y;
5584	}	5933	}
5585		5934
5586	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */	5935	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5587	static int	5936	ecb_hot static int
5588	syntaxnum (pointer p)	5937	syntaxnum (pointer p)
5589	{	5938	{
5590	const char *s = strvalue (p);	5939	const char *s = strvalue (p);
5591		5940
5592	switch (strlength (p))	5941	switch (strlength (p))
…		…
5671		6020
5672	ecb_cold int	6021	ecb_cold int
5673	scheme_init (SCHEME_P)	6022	scheme_init (SCHEME_P)
5674	{	6023	{
5675	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	6024	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5676	pointer x;
5677		6025
5678	/* this memset is not strictly correct, as we assume (intcache)	6026	/* this memset is not strictly correct, as we assume (intcache)
5679	* that memset 0 will also set pointers to 0, but memset does	6027	* that memset 0 will also set pointers to 0, but memset does
5680	* of course not guarantee that. screw such systems.	6028	* of course not guarantee that. screw such systems.
5681	*/	6029	*/
…		…
5699	SCHEME_V->save_inport = NIL;	6047	SCHEME_V->save_inport = NIL;
5700	SCHEME_V->loadport = NIL;	6048	SCHEME_V->loadport = NIL;
5701	SCHEME_V->nesting = 0;	6049	SCHEME_V->nesting = 0;
5702	SCHEME_V->interactive_repl = 0;	6050	SCHEME_V->interactive_repl = 0;
5703		6051
5704	if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS)	6052	if (!alloc_cellseg (SCHEME_A))
5705	{	6053	{
5706	#if USE_ERROR_CHECKING	6054	#if USE_ERROR_CHECKING
5707	SCHEME_V->no_memory = 1;	6055	SCHEME_V->no_memory = 1;
5708	return 0;	6056	return 0;
5709	#endif	6057	#endif
5710	}	6058	}
5711		6059
5712	SCHEME_V->gc_verbose = 0;	6060	SCHEME_V->gc_verbose = 0;
5713	dump_stack_initialize (SCHEME_A);	6061	dump_stack_initialize (SCHEME_A);
5714	SCHEME_V->code = NIL;	6062	SCHEME_V->code = NIL;
5715	SCHEME_V->args = NIL;	6063	SCHEME_V->args = NIL;
5716	SCHEME_V->envir = NIL;	6064	SCHEME_V->envir = NIL;
		6065	SCHEME_V->value = NIL;
5717	SCHEME_V->tracing = 0;	6066	SCHEME_V->tracing = 0;
5718		6067
5719	/* init NIL */	6068	/* init NIL */
5720	set_typeflag (NIL, T_ATOM | T_MARK);	6069	set_typeflag (NIL, T_SPECIAL | T_ATOM);
5721	set_car (NIL, NIL);	6070	set_car (NIL, NIL);
5722	set_cdr (NIL, NIL);	6071	set_cdr (NIL, NIL);
5723	/* init T */	6072	/* init T */
5724	set_typeflag (S_T, T_ATOM | T_MARK);	6073	set_typeflag (S_T, T_SPECIAL | T_ATOM);
5725	set_car (S_T, S_T);	6074	set_car (S_T, S_T);
5726	set_cdr (S_T, S_T);	6075	set_cdr (S_T, S_T);
5727	/* init F */	6076	/* init F */
5728	set_typeflag (S_F, T_ATOM | T_MARK);	6077	set_typeflag (S_F, T_SPECIAL | T_ATOM);
5729	set_car (S_F, S_F);	6078	set_car (S_F, S_F);
5730	set_cdr (S_F, S_F);	6079	set_cdr (S_F, S_F);
5731	/* init EOF_OBJ */	6080	/* init EOF_OBJ */
5732	set_typeflag (S_EOF, T_ATOM | T_MARK);	6081	set_typeflag (S_EOF, T_SPECIAL | T_ATOM);
5733	set_car (S_EOF, S_EOF);	6082	set_car (S_EOF, S_EOF);
5734	set_cdr (S_EOF, S_EOF);	6083	set_cdr (S_EOF, S_EOF);
5735	/* init sink */	6084	/* init sink */
5736	set_typeflag (S_SINK, T_PAIR | T_MARK);	6085	set_typeflag (S_SINK, T_PAIR);
5737	set_car (S_SINK, NIL);	6086	set_car (S_SINK, NIL);
5738		6087
5739	/* init c_nest */	6088	/* init c_nest */
5740	SCHEME_V->c_nest = NIL;	6089	SCHEME_V->c_nest = NIL;
5741		6090
5742	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);	6091	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5743	/* init global_env */	6092	/* init global_env */
5744	new_frame_in_env (SCHEME_A_ NIL);	6093	new_frame_in_env (SCHEME_A_ NIL);
5745	SCHEME_V->global_env = SCHEME_V->envir;	6094	SCHEME_V->global_env = SCHEME_V->envir;
5746	/* init else */	6095	/* init else */
5747	x = mk_symbol (SCHEME_A_ "else");	6096	new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), S_T);
5748	new_slot_in_env (SCHEME_A_ x, S_T);
5749		6097
5750	{	6098	{
5751	static const char *syntax_names[] = {	6099	static const char *syntax_names[] = {
5752	"lambda", "quote", "define", "if", "begin", "set!",	6100	"lambda", "quote", "define", "if", "begin", "set!",
5753	"let", "let*", "letrec", "cond", "delay", "and",	6101	"let", "let*", "letrec", "cond", "delay", "and",
…		…
5777		6125
5778	return !SCHEME_V->no_memory;	6126	return !SCHEME_V->no_memory;
5779	}	6127	}
5780		6128
5781	#if USE_PORTS	6129	#if USE_PORTS
5782	void	6130	ecb_cold void
5783	scheme_set_input_port_file (SCHEME_P_ int fin)	6131	scheme_set_input_port_file (SCHEME_P_ int fin)
5784	{	6132	{
5785	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);	6133	SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5786	}	6134	}
5787		6135
5788	void	6136	ecb_cold void
5789	scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)	6137	scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5790	{	6138	{
5791	SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);	6139	SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5792	}	6140	}
5793		6141
5794	void	6142	ecb_cold void
5795	scheme_set_output_port_file (SCHEME_P_ int fout)	6143	scheme_set_output_port_file (SCHEME_P_ int fout)
5796	{	6144	{
5797	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);	6145	SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5798	}	6146	}
5799		6147
5800	void	6148	ecb_cold void
5801	scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)	6149	scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5802	{	6150	{
5803	SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);	6151	SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5804	}	6152	}
5805	#endif	6153	#endif
5806		6154
5807	void	6155	ecb_cold void
5808	scheme_set_external_data (SCHEME_P_ void *p)	6156	scheme_set_external_data (SCHEME_P_ void *p)
5809	{	6157	{
5810	SCHEME_V->ext_data = p;	6158	SCHEME_V->ext_data = p;
5811	}	6159	}
5812		6160
…		…
5844	SCHEME_V->loadport = NIL;	6192	SCHEME_V->loadport = NIL;
5845	SCHEME_V->gc_verbose = 0;	6193	SCHEME_V->gc_verbose = 0;
5846	gc (SCHEME_A_ NIL, NIL);	6194	gc (SCHEME_A_ NIL, NIL);
5847		6195
5848	for (i = 0; i <= SCHEME_V->last_cell_seg; i++)	6196	for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5849	free (SCHEME_V->alloc_seg[i]);	6197	free (SCHEME_V->cell_seg[i]);
5850		6198
5851	#if SHOW_ERROR_LINE	6199	#if SHOW_ERROR_LINE
5852	for (i = 0; i <= SCHEME_V->file_i; i++)	6200	for (i = 0; i <= SCHEME_V->file_i; i++)
5853	{
5854	if (SCHEME_V->load_stack[i].kind & port_file)	6201	if (SCHEME_V->load_stack[i].kind & port_file)
5855	{	6202	{
5856	fname = SCHEME_V->load_stack[i].rep.stdio.filename;	6203	fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5857		6204
5858	if (fname)	6205	if (fname)
5859	free (fname);	6206	free (fname);
5860	}	6207	}
5861	}
5862	#endif	6208	#endif
5863	}	6209	}
5864		6210
5865	void	6211	ecb_cold void
5866	scheme_load_file (SCHEME_P_ int fin)	6212	scheme_load_file (SCHEME_P_ int fin)
5867	{	6213	{
5868	scheme_load_named_file (SCHEME_A_ fin, 0);	6214	scheme_load_named_file (SCHEME_A_ fin, 0);
5869	}	6215	}
5870		6216
5871	void	6217	ecb_cold void
5872	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)	6218	scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5873	{	6219	{
5874	dump_stack_reset (SCHEME_A);	6220	dump_stack_reset (SCHEME_A);
5875	SCHEME_V->envir = SCHEME_V->global_env;	6221	SCHEME_V->envir = SCHEME_V->global_env;
5876	SCHEME_V->file_i = 0;	6222	SCHEME_V->file_i = 0;
5877	SCHEME_V->load_stack[0].unget = -1;	6223	SCHEME_V->load_stack[0].unget = -1;
5878	SCHEME_V->load_stack[0].kind = port_input | port_file;	6224	SCHEME_V->load_stack[0].kind = port_input | port_file;
5879	SCHEME_V->load_stack[0].rep.stdio.file = fin;	6225	SCHEME_V->load_stack[0].rep.stdio.file = fin;
5880	#if USE_PORTS
5881	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);	6226	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5882	#endif
5883	SCHEME_V->retcode = 0;	6227	SCHEME_V->retcode = 0;
5884		6228
5885	#if USE_PORTS
5886	if (fin == STDIN_FILENO)	6229	if (fin == STDIN_FILENO)
5887	SCHEME_V->interactive_repl = 1;	6230	SCHEME_V->interactive_repl = 1;
5888	#endif
5889		6231
5890	#if USE_PORTS	6232	#if USE_PORTS
5891	#if SHOW_ERROR_LINE	6233	#if SHOW_ERROR_LINE
5892	SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;	6234	SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5893		6235
…		…
5897	#endif	6239	#endif
5898		6240
5899	SCHEME_V->inport = SCHEME_V->loadport;	6241	SCHEME_V->inport = SCHEME_V->loadport;
5900	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	6242	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5901	Eval_Cycle (SCHEME_A_ OP_T0LVL);	6243	Eval_Cycle (SCHEME_A_ OP_T0LVL);
		6244
5902	set_typeflag (SCHEME_V->loadport, T_ATOM);	6245	set_typeflag (SCHEME_V->loadport, T_ATOM);
5903		6246
5904	if (SCHEME_V->retcode == 0)	6247	if (SCHEME_V->retcode == 0)
5905	SCHEME_V->retcode = SCHEME_V->nesting != 0;	6248	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5906	}	6249	}
5907		6250
5908	void	6251	ecb_cold void
5909	scheme_load_string (SCHEME_P_ const char *cmd)	6252	scheme_load_string (SCHEME_P_ const char *cmd)
5910	{	6253	{
		6254	#if USE_PORTs
5911	dump_stack_reset (SCHEME_A);	6255	dump_stack_reset (SCHEME_A);
5912	SCHEME_V->envir = SCHEME_V->global_env;	6256	SCHEME_V->envir = SCHEME_V->global_env;
5913	SCHEME_V->file_i = 0;	6257	SCHEME_V->file_i = 0;
5914	SCHEME_V->load_stack[0].kind = port_input | port_string;	6258	SCHEME_V->load_stack[0].kind = port_input | port_string;
5915	SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */	6259	SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5916	SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);	6260	SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5917	SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;	6261	SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5918	#if USE_PORTS
5919	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);	6262	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5920	#endif
5921	SCHEME_V->retcode = 0;	6263	SCHEME_V->retcode = 0;
5922	SCHEME_V->interactive_repl = 0;	6264	SCHEME_V->interactive_repl = 0;
5923	SCHEME_V->inport = SCHEME_V->loadport;	6265	SCHEME_V->inport = SCHEME_V->loadport;
5924	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	6266	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5925	Eval_Cycle (SCHEME_A_ OP_T0LVL);	6267	Eval_Cycle (SCHEME_A_ OP_T0LVL);
5926	set_typeflag (SCHEME_V->loadport, T_ATOM);	6268	set_typeflag (SCHEME_V->loadport, T_ATOM);
5927		6269
5928	if (SCHEME_V->retcode == 0)	6270	if (SCHEME_V->retcode == 0)
5929	SCHEME_V->retcode = SCHEME_V->nesting != 0;	6271	SCHEME_V->retcode = SCHEME_V->nesting != 0;
		6272	#else
		6273	abort ();
		6274	#endif
5930	}	6275	}
5931		6276
5932	void	6277	ecb_cold void
5933	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)	6278	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5934	{	6279	{
5935	pointer x;	6280	pointer x;
5936		6281
5937	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);	6282	x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
…		…
5942	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);	6287	new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5943	}	6288	}
5944		6289
5945	#if !STANDALONE	6290	#if !STANDALONE
5946		6291
5947	void	6292	ecb_cold void
5948	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)	6293	scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5949	{	6294	{
5950	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));	6295	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5951	}	6296	}
5952		6297
5953	void	6298	ecb_cold void
5954	scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)	6299	scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5955	{	6300	{
5956	int i;	6301	int i;
5957		6302
5958	for (i = 0; i < count; i++)	6303	for (i = 0; i < count; i++)
5959	scheme_register_foreign_func (SCHEME_A_ list + i);	6304	scheme_register_foreign_func (SCHEME_A_ list + i);
5960	}	6305	}
5961		6306
5962	pointer	6307	ecb_cold pointer
5963	scheme_apply0 (SCHEME_P_ const char *procname)	6308	scheme_apply0 (SCHEME_P_ const char *procname)
5964	{	6309	{
5965	return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));	6310	return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5966	}	6311	}
5967		6312
5968	void	6313	ecb_cold void
5969	save_from_C_call (SCHEME_P)	6314	save_from_C_call (SCHEME_P)
5970	{	6315	{
5971	pointer saved_data = cons (car (S_SINK),	6316	pointer saved_data = cons (car (S_SINK),
5972	cons (SCHEME_V->envir,	6317	cons (SCHEME_V->envir,
5973	SCHEME_V->dump));	6318	SCHEME_V->dump));
…		…
5977	/* Truncate the dump stack so TS will return here when done, not	6322	/* Truncate the dump stack so TS will return here when done, not
5978	directly resume pre-C-call operations. */	6323	directly resume pre-C-call operations. */
5979	dump_stack_reset (SCHEME_A);	6324	dump_stack_reset (SCHEME_A);
5980	}	6325	}
5981		6326
5982	void	6327	ecb_cold void
5983	restore_from_C_call (SCHEME_P)	6328	restore_from_C_call (SCHEME_P)
5984	{	6329	{
5985	set_car (S_SINK, caar (SCHEME_V->c_nest));	6330	set_car (S_SINK, caar (SCHEME_V->c_nest));
5986	SCHEME_V->envir = cadar (SCHEME_V->c_nest);	6331	SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5987	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));	6332	SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5988	/* Pop */	6333	/* Pop */
5989	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);	6334	SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5990	}	6335	}
5991		6336
5992	/* "func" and "args" are assumed to be already eval'ed. */	6337	/* "func" and "args" are assumed to be already eval'ed. */
5993	pointer	6338	ecb_cold pointer
5994	scheme_call (SCHEME_P_ pointer func, pointer args)	6339	scheme_call (SCHEME_P_ pointer func, pointer args)
5995	{	6340	{
5996	int old_repl = SCHEME_V->interactive_repl;	6341	int old_repl = SCHEME_V->interactive_repl;
5997		6342
5998	SCHEME_V->interactive_repl = 0;	6343	SCHEME_V->interactive_repl = 0;
…		…
6005	SCHEME_V->interactive_repl = old_repl;	6350	SCHEME_V->interactive_repl = old_repl;
6006	restore_from_C_call (SCHEME_A);	6351	restore_from_C_call (SCHEME_A);
6007	return SCHEME_V->value;	6352	return SCHEME_V->value;
6008	}	6353	}
6009		6354
6010	pointer	6355	ecb_cold pointer
6011	scheme_eval (SCHEME_P_ pointer obj)	6356	scheme_eval (SCHEME_P_ pointer obj)
6012	{	6357	{
6013	int old_repl = SCHEME_V->interactive_repl;	6358	int old_repl = SCHEME_V->interactive_repl;
6014		6359
6015	SCHEME_V->interactive_repl = 0;	6360	SCHEME_V->interactive_repl = 0;
…		…
6027		6372
6028	/* ========== Main ========== */	6373	/* ========== Main ========== */
6029		6374
6030	#if STANDALONE	6375	#if STANDALONE
6031		6376
6032	int	6377	ecb_cold int
6033	main (int argc, char **argv)	6378	main (int argc, char **argv)
6034	{	6379	{
6035	# if USE_MULTIPLICITY	6380	# if USE_MULTIPLICITY
6036	scheme ssc;	6381	scheme ssc;
6037	scheme *const SCHEME_V = &ssc;	6382	scheme *const SCHEME_V = &ssc;
…		…
6039	# endif	6384	# endif
6040	int fin;	6385	int fin;
6041	char *file_name = InitFile;	6386	char *file_name = InitFile;
6042	int retcode;	6387	int retcode;
6043	int isfile = 1;	6388	int isfile = 1;
		6389	#if EXPERIMENT
6044	system ("ps v $PPID");//D	6390	system ("ps v $PPID");
		6391	#endif
6045		6392
6046	if (argc == 2 && strcmp (argv[1], "-?") == 0)	6393	if (argc == 2 && strcmp (argv[1], "-?") == 0)
6047	{	6394	{
6048	xwrstr ("Usage: tinyscheme -?\n");	6395	putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6049	xwrstr ("or: tinyscheme [<file1> <file2> ...]\n");	6396	putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6050	xwrstr ("followed by\n");	6397	putstr (SCHEME_A_ "followed by\n");
6051	xwrstr (" -1 <file> [<arg1> <arg2> ...]\n");	6398	putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6052	xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n");	6399	putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6053	xwrstr ("assuming that the executable is named tinyscheme.\n");	6400	putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6054	xwrstr ("Use - as filename for stdin.\n");	6401	putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6055	return 1;	6402	return 1;
6056	}	6403	}
6057		6404
6058	if (!scheme_init (SCHEME_A))	6405	if (!scheme_init (SCHEME_A))
6059	{	6406	{
6060	xwrstr ("Could not initialize!\n");	6407	putstr (SCHEME_A_ "Could not initialize!\n");
6061	return 2;	6408	return 2;
6062	}	6409	}
6063		6410
6064	# if USE_PORTS	6411	# if USE_PORTS
6065	scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);	6412	scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
…		…
6078	}	6425	}
6079	#endif	6426	#endif
6080		6427
6081	do	6428	do
6082	{	6429	{
6083	#if USE_PORTS
6084	if (strcmp (file_name, "-") == 0)	6430	if (strcmp (file_name, "-") == 0)
6085	fin = STDIN_FILENO;	6431	fin = STDIN_FILENO;
6086	else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)	6432	else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
6087	{	6433	{
6088	pointer args = NIL;	6434	pointer args = NIL;
…		…
6106	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);	6452	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
6107		6453
6108	}	6454	}
6109	else	6455	else
6110	fin = open (file_name, O_RDONLY);	6456	fin = open (file_name, O_RDONLY);
6111	#endif
6112		6457
6113	if (isfile && fin < 0)	6458	if (isfile && fin < 0)
6114	{	6459	{
6115	xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n");	6460	putstr (SCHEME_A_ "Could not open file ");
		6461	putstr (SCHEME_A_ file_name);
		6462	putcharacter (SCHEME_A_ '\n');
6116	}	6463	}
6117	else	6464	else
6118	{	6465	{
6119	if (isfile)	6466	if (isfile)
6120	scheme_load_named_file (SCHEME_A_ fin, file_name);	6467	scheme_load_named_file (SCHEME_A_ fin, file_name);
6121	else	6468	else
6122	scheme_load_string (SCHEME_A_ file_name);	6469	scheme_load_string (SCHEME_A_ file_name);
6123		6470
6124	#if USE_PORTS
6125	if (!isfile || fin != STDIN_FILENO)	6471	if (!isfile || fin != STDIN_FILENO)
6126	{	6472	{
6127	if (SCHEME_V->retcode != 0)	6473	if (SCHEME_V->retcode != 0)
6128	{	6474	{
6129	xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n");	6475	putstr (SCHEME_A_ "Errors encountered reading ");
		6476	putstr (SCHEME_A_ file_name);
		6477	putcharacter (SCHEME_A_ '\n');
6130	}	6478	}
6131		6479
6132	if (isfile)	6480	if (isfile)
6133	close (fin);	6481	close (fin);
6134	}	6482	}
6135	#endif
6136	}	6483	}
6137		6484
6138	file_name = *argv++;	6485	file_name = *argv++;
6139	}	6486	}
6140	while (file_name != 0);	6487	while (file_name != 0);

Diff Legend

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