[ViewVC] Diff of: cvs/microscheme/scheme.c

Comparing microscheme/scheme.c (file contents):
Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC vs.
Revision 1.61 by root, Wed Dec 2 07:43:46 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 _GNU_SOURCE 1
		22	#define _POSIX_C_SOURCE 200201
		23	#define _XOPEN_SOURCE 600
22		24
23	#if 1
24	#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
25	#include "malloc.c"
26	#endif
27		25
28	#define SCHEME_SOURCE	26	#define SCHEME_SOURCE
29	#include "scheme-private.h"	27	#include "scheme-private.h"
30	#ifndef WIN32	28	#ifndef WIN32
31	# include <unistd.h>	29	# include <unistd.h>
…		…
49	#include <string.h>	47	#include <string.h>
50		48
51	#include <limits.h>	49	#include <limits.h>
52	#include <inttypes.h>	50	#include <inttypes.h>
53	#include <float.h>	51	#include <float.h>
54	//#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
55		60
56	#if '1' != '0' + 1 \	61	#if '1' != '0' + 1 \
57	\|\| '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 \
58	\|\| '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 \
59	\|\| '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 \
…		…
131		136
132	xnum (buf, n);	137	xnum (buf, n);
133	putstr (SCHEME_A_ buf);	138	putstr (SCHEME_A_ buf);
134	}	139	}
135		140
136	ecb_cold static char	141	#if USE_CHAR_CLASSIFIERS
		142	#include <ctype.h>
		143	#else
		144
		145	static char
137	xtoupper (char c)	146	xtoupper (char c)
138	{	147	{
139	if (c >= 'a' && c <= 'z')	148	if (c >= 'a' && c <= 'z')
140	c -= 'a' - 'A';	149	c -= 'a' - 'A';
141		150
142	return c;	151	return c;
143	}	152	}
144		153
145	ecb_cold static char	154	static char
146	xtolower (char c)	155	xtolower (char c)
147	{	156	{
148	if (c >= 'A' && c <= 'Z')	157	if (c >= 'A' && c <= 'Z')
149	c += 'a' - 'A';	158	c += 'a' - 'A';
150		159
151	return c;	160	return c;
152	}	161	}
153		162
154	ecb_cold static int	163	static int
155	xisdigit (char c)	164	xisdigit (char c)
156	{	165	{
157	return c >= '0' && c <= '9';	166	return c >= '0' && c <= '9';
158	}	167	}
159		168
160	#define toupper(c) xtoupper (c)	169	#define toupper(c) xtoupper (c)
161	#define tolower(c) xtolower (c)	170	#define tolower(c) xtolower (c)
162	#define isdigit(c) xisdigit (c)	171	#define isdigit(c) xisdigit (c)
		172
		173	#endif
163		174
164	#if USE_IGNORECASE	175	#if USE_IGNORECASE
165	ecb_cold static const char *	176	ecb_cold static const char *
166	xstrlwr (char *s)	177	xstrlwr (char *s)
167	{	178	{
…		…
200	T_STRING,	211	T_STRING,
201	T_SYMBOL,	212	T_SYMBOL,
202	T_PROC,	213	T_PROC,
203	T_PAIR, /* also used for free cells */	214	T_PAIR, /* also used for free cells */
204	T_CLOSURE,	215	T_CLOSURE,
		216	T_BYTECODE, // temp
205	T_MACRO,	217	T_MACRO,
206	T_CONTINUATION,	218	T_CONTINUATION,
207	T_FOREIGN,	219	T_FOREIGN,
208	T_PORT,	220	T_PORT,
209	T_VECTOR,	221	T_VECTOR,
210	T_PROMISE,	222	T_PROMISE,
211	T_ENVIRONMENT,	223	T_ENVIRONMENT,
212	/* one more... */	224
213	T_NUM_SYSTEM_TYPES	225	T_NUM_SYSTEM_TYPES
214	};	226	};
215		227
216	#define T_MASKTYPE 0x000f	228	#define T_MASKTYPE 0x000f
217	#define T_SYNTAX 0x0010	229	#define T_SYNTAX 0x0010
…		…
569	{	581	{
570	return list_length (SCHEME_A_ a) >= 0;	582	return list_length (SCHEME_A_ a) >= 0;
571	}	583	}
572		584
573	#if USE_CHAR_CLASSIFIERS	585	#if USE_CHAR_CLASSIFIERS
		586
574	ecb_inline int	587	ecb_inline int
575	Cisalpha (int c)	588	Cisalpha (int c)
576	{	589	{
577	return isascii (c) && isalpha (c);	590	return isascii (c) && isalpha (c);
578	}	591	}
…		…
668	static int file_interactive (SCHEME_P);	681	static int file_interactive (SCHEME_P);
669	ecb_inline int is_one_of (const char *s, int c);	682	ecb_inline int is_one_of (const char *s, int c);
670	static int alloc_cellseg (SCHEME_P);	683	static int alloc_cellseg (SCHEME_P);
671	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);	684	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
672	static void finalize_cell (SCHEME_P_ pointer a);	685	static void finalize_cell (SCHEME_P_ pointer a);
673	static int count_consecutive_cells (pointer x, int needed);
674	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	686	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
675	static pointer mk_number (SCHEME_P_ const num n);	687	static pointer mk_number (SCHEME_P_ const num n);
676	static char store_string (SCHEME_P_ uint32_t len, const char str, char fill);	688	static char store_string (SCHEME_P_ uint32_t len, const char str, char fill);
677	static pointer mk_vector (SCHEME_P_ uint32_t len);	689	static pointer mk_vector (SCHEME_P_ uint32_t len);
678	static pointer mk_atom (SCHEME_P_ char *q);	690	static pointer mk_atom (SCHEME_P_ char *q);
679	static pointer mk_sharp_const (SCHEME_P_ char *name);	691	static pointer mk_sharp_const (SCHEME_P_ char *name);
680		692
		693	static pointer mk_port (SCHEME_P_ port *p);
		694
681	#if USE_PORTS	695	#if USE_PORTS
682	static pointer mk_port (SCHEME_P_ port *p);
683	static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);	696	static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
684	static pointer port_from_file (SCHEME_P_ int, int prop);	697	static pointer port_from_file (SCHEME_P_ int, int prop);
685	static pointer port_from_string (SCHEME_P_ char start, char past_the_end, int prop);	698	static pointer port_from_string (SCHEME_P_ char start, char past_the_end, int prop);
686	static port port_rep_from_filename (SCHEME_P_ const char fn, int prop);	699	static port port_rep_from_filename (SCHEME_P_ const char fn, int prop);
687	static port *port_rep_from_file (SCHEME_P_ int, int prop);	700	static port *port_rep_from_file (SCHEME_P_ int, int prop);
688	static port port_rep_from_string (SCHEME_P_ char start, char *past_the_end, int prop);	701	static port port_rep_from_string (SCHEME_P_ char start, char *past_the_end, int prop);
689	static void port_close (SCHEME_P_ pointer p, int flag);	702	static void port_close (SCHEME_P_ pointer p, int flag);
690	#endif	703	#endif
		704
691	static void mark (pointer a);	705	static void mark (pointer a);
692	static void gc (SCHEME_P_ pointer a, pointer b);	706	static void gc (SCHEME_P_ pointer a, pointer b);
693	static int basic_inchar (port *pt);	707	static int basic_inchar (port *pt);
694	static int inchar (SCHEME_P);	708	static int inchar (SCHEME_P);
695	static void backchar (SCHEME_P_ int c);	709	static void backchar (SCHEME_P_ int c);
…		…
935	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	949	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
936	return S_SINK;	950	return S_SINK;
937		951
938	if (SCHEME_V->free_cell == NIL)	952	if (SCHEME_V->free_cell == NIL)
939	{	953	{
940	const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1;	954	const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
941		955
942	gc (SCHEME_A_ a, b);	956	gc (SCHEME_A_ a, b);
943		957
944	if (SCHEME_V->fcells < min_to_be_recovered \|\| SCHEME_V->free_cell == NIL)	958	if (SCHEME_V->fcells < min_to_be_recovered \|\| SCHEME_V->free_cell == NIL)
945	{	959	{
…		…
1043	#endif	1057	#endif
1044		1058
1045	/* Medium level cell allocation */	1059	/* Medium level cell allocation */
1046		1060
1047	/* get new cons cell */	1061	/* get new cons cell */
1048	ecb_hot pointer	1062	ecb_hot static pointer
1049	xcons (SCHEME_P_ pointer a, pointer b, int immutable)	1063	xcons (SCHEME_P_ pointer a, pointer b)
1050	{	1064	{
1051	pointer x = get_cell (SCHEME_A_ a, b);	1065	pointer x = get_cell (SCHEME_A_ a, b);
1052		1066
1053	set_typeflag (x, T_PAIR);	1067	set_typeflag (x, T_PAIR);
1054
1055	if (immutable)
1056	setimmutable (x);
1057		1068
1058	set_car (x, a);	1069	set_car (x, a);
1059	set_cdr (x, b);	1070	set_cdr (x, b);
1060		1071
1061	return x;	1072	return x;
1062	}	1073	}
		1074
		1075	ecb_hot static pointer
		1076	ximmutable_cons (SCHEME_P_ pointer a, pointer b)
		1077	{
		1078	pointer x = xcons (SCHEME_A_ a, b);
		1079	setimmutable (x);
		1080	return x;
		1081	}
		1082
		1083	#define cons(a,b) xcons (SCHEME_A_ a, b)
		1084	#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1063		1085
1064	ecb_cold static pointer	1086	ecb_cold static pointer
1065	generate_symbol (SCHEME_P_ const char *name)	1087	generate_symbol (SCHEME_P_ const char *name)
1066	{	1088	{
1067	pointer x = mk_string (SCHEME_A_ name);	1089	pointer x = mk_string (SCHEME_A_ name);
…		…
1075	#ifndef USE_OBJECT_LIST	1097	#ifndef USE_OBJECT_LIST
1076		1098
1077	static int	1099	static int
1078	hash_fn (const char *key, int table_size)	1100	hash_fn (const char *key, int table_size)
1079	{	1101	{
1080	const unsigned char *p = key;	1102	const unsigned char p = (unsigned char )key;
1081	uint32_t hash = 2166136261;	1103	uint32_t hash = 2166136261;
1082		1104
1083	while (*p)	1105	while (*p)
1084	hash = (hash ^ p++) 16777619;	1106	hash = (hash ^ p++) 16777619;
1085		1107
…		…
1178	return SCHEME_V->oblist;	1200	return SCHEME_V->oblist;
1179	}	1201	}
1180		1202
1181	#endif	1203	#endif
1182		1204
1183	#if USE_PORTS
1184	ecb_cold static pointer	1205	ecb_cold static pointer
1185	mk_port (SCHEME_P_ port *p)	1206	mk_port (SCHEME_P_ port *p)
1186	{	1207	{
1187	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1208	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1188		1209
1189	set_typeflag (x, T_PORT \| T_ATOM);	1210	set_typeflag (x, T_PORT \| T_ATOM);
1190	set_port (x, p);	1211	set_port (x, p);
1191		1212
1192	return x;	1213	return x;
1193	}	1214	}
1194	#endif
1195		1215
1196	ecb_cold pointer	1216	ecb_cold pointer
1197	mk_foreign_func (SCHEME_P_ foreign_func f)	1217	mk_foreign_func (SCHEME_P_ foreign_func f)
1198	{	1218	{
1199	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1219	pointer x = get_cell (SCHEME_A_ NIL, NIL);
…		…
1722	/* ========== Routines for Reading ========== */	1742	/* ========== Routines for Reading ========== */
1723		1743
1724	ecb_cold static int	1744	ecb_cold static int
1725	file_push (SCHEME_P_ const char *fname)	1745	file_push (SCHEME_P_ const char *fname)
1726	{	1746	{
1727	#if USE_PORTS
1728	int fin;	1747	int fin;
1729		1748
1730	if (SCHEME_V->file_i == MAXFIL - 1)	1749	if (SCHEME_V->file_i == MAXFIL - 1)
1731	return 0;	1750	return 0;
1732		1751
…		…
1749	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);	1768	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1750	#endif	1769	#endif
1751	}	1770	}
1752		1771
1753	return fin >= 0;	1772	return fin >= 0;
1754
1755	#else
1756	return 1;
1757	#endif
1758	}	1773	}
1759		1774
1760	ecb_cold static void	1775	ecb_cold static void
1761	file_pop (SCHEME_P)	1776	file_pop (SCHEME_P)
1762	{	1777	{
…		…
1946	}	1961	}
1947	}	1962	}
1948	#endif	1963	#endif
1949		1964
1950	/* get new character from input file */	1965	/* get new character from input file */
1951	static int	1966	ecb_cold static int
1952	inchar (SCHEME_P)	1967	inchar (SCHEME_P)
1953	{	1968	{
1954	int c;	1969	int c;
1955	port *pt = port (SCHEME_V->inport);	1970	port *pt = port (SCHEME_V->inport);
1956		1971
…		…
1970	}	1985	}
1971		1986
1972	return c;	1987	return c;
1973	}	1988	}
1974		1989
1975	static int ungot = -1;	1990	ecb_cold static int
1976
1977	static int
1978	basic_inchar (port *pt)	1991	basic_inchar (port *pt)
1979	{	1992	{
1980	#if USE_PORTS
1981	if (pt->unget != -1)	1993	if (pt->unget != -1)
1982	{	1994	{
1983	int r = pt->unget;	1995	int r = pt->unget;
1984	pt->unget = -1;	1996	pt->unget = -1;
1985	return r;	1997	return r;
1986	}	1998	}
1987		1999
		2000	#if USE_PORTS
1988	if (pt->kind & port_file)	2001	if (pt->kind & port_file)
1989	{	2002	{
1990	char c;	2003	char c;
1991		2004
1992	if (!read (pt->rep.stdio.file, &c, 1))	2005	if (!read (pt->rep.stdio.file, &c, 1))
…		…
2000	return EOF;	2013	return EOF;
2001	else	2014	else
2002	return *pt->rep.string.curr++;	2015	return *pt->rep.string.curr++;
2003	}	2016	}
2004	#else	2017	#else
2005	if (ungot == -1)
2006	{
2007	char c;	2018	char c;
2008	if (!read (0, &c, 1))	2019
		2020	if (!read (pt->rep.stdio.file, &c, 1))
2009	return EOF;	2021	return EOF;
2010		2022
2011	ungot = c;
2012	}
2013
2014	{
2015	int r = ungot;
2016	ungot = -1;
2017	return r;	2023	return c;
2018	}
2019	#endif	2024	#endif
2020	}	2025	}
2021		2026
2022	/* back character to input buffer */	2027	/* back character to input buffer */
2023	static void	2028	ecb_cold static void
2024	backchar (SCHEME_P_ int c)	2029	backchar (SCHEME_P_ int c)
2025	{	2030	{
2026	#if USE_PORTS	2031	port *pt = port (SCHEME_V->inport);
2027	port *pt;
2028		2032
2029	if (c == EOF)	2033	if (c == EOF)
2030	return;	2034	return;
2031		2035
2032	pt = port (SCHEME_V->inport);
2033	pt->unget = c;	2036	pt->unget = c;
2034	#else
2035	if (c == EOF)
2036	return;
2037
2038	ungot = c;
2039	#endif
2040	}	2037	}
2041		2038
2042	#if USE_PORTS	2039	#if USE_PORTS
2043	ecb_cold static int	2040	ecb_cold static int
2044	realloc_port_string (SCHEME_P_ port *p)	2041	realloc_port_string (SCHEME_P_ port *p)
…		…
2061	else	2058	else
2062	return 0;	2059	return 0;
2063	}	2060	}
2064	#endif	2061	#endif
2065		2062
2066	ecb_cold INTERFACE void
2067	putstr (SCHEME_P_ const char *s)
2068	{
2069	#if USE_PORTS
2070	port *pt = port (SCHEME_V->outport);
2071
2072	if (pt->kind & port_file)
2073	write (pt->rep.stdio.file, s, strlen (s));
2074	else
2075	for (; *s; s++)
2076	if (pt->rep.string.curr != pt->rep.string.past_the_end)
2077	pt->rep.string.curr++ = s;
2078	else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2079	pt->rep.string.curr++ = s;
2080
2081	#else
2082	write (pt->rep.stdio.file, s, strlen (s));
2083	#endif
2084	}
2085
2086	ecb_cold static void	2063	ecb_cold static void
2087	putchars (SCHEME_P_ const char *s, int len)	2064	putchars (SCHEME_P_ const char *s, int len)
2088	{	2065	{
		2066	port *pt = port (SCHEME_V->outport);
		2067
2089	#if USE_PORTS	2068	#if USE_PORTS
2090	port *pt = port (SCHEME_V->outport);
2091
2092	if (pt->kind & port_file)	2069	if (pt->kind & port_file)
2093	write (pt->rep.stdio.file, s, len);	2070	write (pt->rep.stdio.file, s, len);
2094	else	2071	else
2095	{	2072	{
2096	for (; len; len--)	2073	for (; len; len--)
…		…
2101	pt->rep.string.curr++ = s++;	2078	pt->rep.string.curr++ = s++;
2102	}	2079	}
2103	}	2080	}
2104		2081
2105	#else	2082	#else
2106	write (1, s, len);	2083	write (1, s, len); // output not initialised
2107	#endif	2084	#endif
2108	}	2085	}
2109		2086
2110	ecb_cold INTERFACE void	2087	INTERFACE void
		2088	putstr (SCHEME_P_ const char *s)
		2089	{
		2090	putchars (SCHEME_A_ s, strlen (s));
		2091	}
		2092
		2093	INTERFACE void
2111	putcharacter (SCHEME_P_ int c)	2094	putcharacter (SCHEME_P_ int c)
2112	{	2095	{
2113	#if USE_PORTS
2114	port *pt = port (SCHEME_V->outport);
2115
2116	if (pt->kind & port_file)
2117	{
2118	char cc = c;
2119	write (pt->rep.stdio.file, &cc, 1);
2120	}
2121	else
2122	{
2123	if (pt->rep.string.curr != pt->rep.string.past_the_end)
2124	*pt->rep.string.curr++ = c;
2125	else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2126	*pt->rep.string.curr++ = c;
2127	}
2128
2129	#else
2130	char cc = c;	2096	char cc = c;
2131	write (1, &c, 1);	2097
2132	#endif	2098	putchars (SCHEME_A_ &cc, 1);
2133	}	2099	}
2134		2100
2135	/* read characters up to delimiter, but cater to character constants */	2101	/* read characters up to delimiter, but cater to character constants */
2136	ecb_cold static char *	2102	ecb_cold static char *
2137	readstr_upto (SCHEME_P_ int skip, const char *delim)	2103	readstr_upto (SCHEME_P_ int skip, const char *delim)
…		…
2198	case 'a': *p++ = '\a'; state = st_ok; break;	2164	case 'a': *p++ = '\a'; state = st_ok; break;
2199	case 'n': *p++ = '\n'; state = st_ok; break;	2165	case 'n': *p++ = '\n'; state = st_ok; break;
2200	case 'r': *p++ = '\r'; state = st_ok; break;	2166	case 'r': *p++ = '\r'; state = st_ok; break;
2201	case 't': *p++ = '\t'; state = st_ok; break;	2167	case 't': *p++ = '\t'; state = st_ok; break;
2202		2168
2203	//TODO: \whitespace eol whitespace	2169	case '\\':
		2170	skipspace (SCHEME_A);
		2171	break;
2204		2172
2205	//TODO: x should end in ;, not two-digit hex	2173	//TODO: x should end in ;, not two-digit hex
2206	case 'x':	2174	case 'x':
2207	case 'X':	2175	case 'X':
2208	state = st_x1;	2176	state = st_x1;
…		…
3246	#endif	3214	#endif
3247		3215
3248	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3216	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3249		3217
3250	#if EXPERIMENT	3218	#if EXPERIMENT
		3219
		3220	typedef void *stream[1];
		3221
		3222	#define stream_init() { 0 }
		3223
		3224	ecb_cold static void
		3225	stream_put (void **s, uint8_t byte)
		3226	{
		3227	uint32_t sp = s;
		3228	uint32_t size = sizeof (uint32_t) * 2;
		3229	uint32_t offs = size;
		3230
		3231	if (ecb_expect_true (sp))
		3232	{
		3233	offs = sp[0];
		3234	size = sp[1];
		3235	}
		3236
		3237	if (ecb_expect_false (offs == size))
		3238	{
		3239	size *= 2;
		3240	sp = realloc (sp, size);
		3241	*s = sp;
		3242	sp[1] = size;
		3243
		3244	}
		3245
		3246	((uint8_t *)sp)[offs++] = byte;
		3247	sp[0] = offs;
		3248	}
		3249
		3250	#define stream_data(s) ((char )(s)[0] + sizeof (uint32_t) 2)
		3251	#define stream_size(s) (((uint32_t )(s)[0])[0] - sizeof (uint32_t) 2)
		3252	#define stream_free(s) free (s[0])
		3253
		3254	// calculates a (preferably small) integer that makes it possible to find
		3255	// the symbol again. if pointers were offsets into a memory area... until
		3256	// then, we return segment number in the low bits, and offset in the high
		3257	// bits
		3258	static uint32_t
		3259	symbol_id (SCHEME_P_ pointer sym)
		3260	{
		3261	struct cell *p = CELL (sym);
		3262	int i;
		3263
		3264	for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
		3265	if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
		3266	{
		3267	printf ("seg %d ofs %d/%d\n",i,(p - SCHEME_V->cell_seg[i]),SCHEME_V->cell_segsize[i]);//D
		3268	return i \| ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
		3269	}
		3270
		3271	abort ();
		3272	}
		3273
		3274	static void
		3275	compile (SCHEME_P_ stream s, pointer x)
		3276	{
		3277	if (x == NIL)
		3278	{
		3279	stream_put (s, 0);
		3280	return;
		3281	}
		3282
		3283	if (is_syntax (x))
		3284	{
		3285	stream_put (s, 1);
		3286	stream_put (s, syntaxnum (x));
		3287	return;
		3288	}
		3289
		3290	switch (type (x))
		3291	{
		3292	case T_INTEGER:
		3293	stream_put (s, 2);
		3294	stream_put (s, 0);
		3295	stream_put (s, 0);
		3296	stream_put (s, 0);
		3297	stream_put (s, 0);
		3298	return;
		3299
		3300	case T_SYMBOL:
		3301	{
		3302	uint32_t sym = symbol_id (SCHEME_A_ x);
		3303	printf ("sym %x\n", sym);//D
		3304
		3305	stream_put (s, 3);
		3306
		3307	while (sym > 0x7f)
		3308	{
		3309	stream_put (s, sym \| 0x80);
		3310	sym >>= 8;
		3311	}
		3312
		3313	stream_put (s, sym);
		3314	}
		3315	return;
		3316
		3317	case T_PAIR:
		3318	stream_put (s, 4);
		3319	while (x != NIL)
		3320	{
		3321	compile (SCHEME_A_ s, car (x));
		3322	x = cdr (x);
		3323	}
		3324	stream_put (s, 0xff);
		3325	return;
		3326
		3327	default:
		3328	stream_put (s, 5);
		3329	stream_put (s, type (x));
		3330	stream_put (s, 0);
		3331	stream_put (s, 0);
		3332	stream_put (s, 0);
		3333	stream_put (s, 0);
		3334	break;
		3335	}
		3336	}
		3337
3251	static int	3338	static int
		3339	compile_closure (SCHEME_P_ pointer p)
		3340	{
		3341	stream s = stream_init ();
		3342
		3343	printatom (SCHEME_A_ p, 1);//D
		3344	compile (SCHEME_A_ s, car (p));
		3345
		3346	FILE *xxd = popen ("xxd", "we");
		3347	fwrite (stream_data (s), 1, stream_size (s), xxd);
		3348	fclose (xxd);
		3349
		3350	return stream_size (s);
		3351	}
		3352
		3353	static int
3252	debug (SCHEME_P_ int indent, pointer x)	3354	dtree (SCHEME_P_ int indent, pointer x)
3253	{	3355	{
3254	int c;	3356	int c;
3255		3357
3256	if (is_syntax (x))	3358	if (is_syntax (x))
3257	{	3359	{
…		…
3275	printf ("%*sS<%s>\n", indent, "", symname (x));	3377	printf ("%*sS<%s>\n", indent, "", symname (x));
3276	return 24+8;	3378	return 24+8;
3277		3379
3278	case T_CLOSURE:	3380	case T_CLOSURE:
3279	printf ("%*sS<%s>\n", indent, "", "closure");	3381	printf ("%*sS<%s>\n", indent, "", "closure");
3280	debug (SCHEME_A_ indent + 3, cdr(x));	3382	dtree (SCHEME_A_ indent + 3, cdr(x));
3281	return 32 + debug (SCHEME_A_ indent + 3, car (x));	3383	return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3282		3384
3283	case T_PAIR:	3385	case T_PAIR:
3284	printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));	3386	printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3285	c = debug (SCHEME_A_ indent + 3, car (x));	3387	c = dtree (SCHEME_A_ indent + 3, car (x));
3286	c += debug (SCHEME_A_ indent + 3, cdr (x));	3388	c += dtree (SCHEME_A_ indent + 3, cdr (x));
3287	return c + 1;	3389	return c + 1;
3288		3390
3289	case T_PORT:	3391	case T_PORT:
3290	printf ("%*sS<%s>\n", indent, "", "port");	3392	printf ("%*sS<%s>\n", indent, "", "port");
3291	return 24+8;	3393	return 24+8;
…		…
3294	printf ("%*sS<%s>\n", indent, "", "vector");	3396	printf ("%*sS<%s>\n", indent, "", "vector");
3295	return 24+8;	3397	return 24+8;
3296		3398
3297	case T_ENVIRONMENT:	3399	case T_ENVIRONMENT:
3298	printf ("%*sS<%s>\n", indent, "", "environment");	3400	printf ("%*sS<%s>\n", indent, "", "environment");
3299	return 0 + debug (SCHEME_A_ indent + 3, car (x));	3401	return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3300		3402
3301	default:	3403	default:
3302	printf ("unhandled type %d\n", type (x));	3404	printf ("unhandled type %d\n", type (x));
3303	break;	3405	break;
3304	}	3406	}
…		…
3314		3416
3315	switch (op)	3417	switch (op)
3316	{	3418	{
3317	#if EXPERIMENT //D	3419	#if EXPERIMENT //D
3318	case OP_DEBUG:	3420	case OP_DEBUG:
3319	printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);	3421	{
		3422	uint32_t len = compile_closure (SCHEME_A_ car (args));
		3423	printf ("len = %d\n", len);
3320	printf ("\n");	3424	printf ("\n");
3321	s_return (S_T);	3425	s_return (S_T);
		3426	}
3322	#endif	3427	#endif
3323	case OP_LOAD: /* load */	3428	case OP_LOAD: /* load */
3324	if (file_interactive (SCHEME_A))	3429	if (file_interactive (SCHEME_A))
3325	{	3430	{
3326	putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");	3431	putstr (SCHEME_A_ "Loading ");
3327	//D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));	3432	putstr (SCHEME_A_ strvalue (car (args)));
		3433	putcharacter (SCHEME_A_ '\n');
3328	}	3434	}
3329		3435
3330	if (!file_push (SCHEME_A_ strvalue (car (args))))	3436	if (!file_push (SCHEME_A_ strvalue (car (args))))
3331	Error_1 ("unable to open", car (args));	3437	Error_1 ("unable to open", car (args));
3332	else	3438
3333	{
3334	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	3439	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3335	s_goto (OP_T0LVL);	3440	s_goto (OP_T0LVL);
3336	}
3337		3441
3338	case OP_T0LVL: /* top level */	3442	case OP_T0LVL: /* top level */
3339		3443
3340	/* If we reached the end of file, this loop is done. */	3444	/* If we reached the end of file, this loop is done. */
3341	if (port (SCHEME_V->loadport)->kind & port_saw_EOF)	3445	if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
…		…
3357	/* If interactive, be nice to user. */	3461	/* If interactive, be nice to user. */
3358	if (file_interactive (SCHEME_A))	3462	if (file_interactive (SCHEME_A))
3359	{	3463	{
3360	SCHEME_V->envir = SCHEME_V->global_env;	3464	SCHEME_V->envir = SCHEME_V->global_env;
3361	dump_stack_reset (SCHEME_A);	3465	dump_stack_reset (SCHEME_A);
3362	putstr (SCHEME_A_ "\n");	3466	putcharacter (SCHEME_A_ '\n');
3363	putstr (SCHEME_A_ prompt);	3467	putstr (SCHEME_A_ prompt);
3364	}	3468	}
3365		3469
3366	/* Set up another iteration of REPL */	3470	/* Set up another iteration of REPL */
3367	SCHEME_V->nesting = 0;	3471	SCHEME_V->nesting = 0;
…		…
3402	{	3506	{
3403	SCHEME_V->print_flag = 1;	3507	SCHEME_V->print_flag = 1;
3404	SCHEME_V->args = SCHEME_V->value;	3508	SCHEME_V->args = SCHEME_V->value;
3405	s_goto (OP_P0LIST);	3509	s_goto (OP_P0LIST);
3406	}	3510	}
3407	else	3511
3408	s_return (SCHEME_V->value);	3512	s_return (SCHEME_V->value);
3409		3513
3410	case OP_EVAL: /* main part of evaluation */	3514	case OP_EVAL: /* main part of evaluation */
3411	#if USE_TRACING	3515	#if USE_TRACING
3412	if (SCHEME_V->tracing)	3516	if (SCHEME_V->tracing)
3413	{	3517	{
…		…
3446	/* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */	3550	/* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3447	SCHEME_V->code = x;	3551	SCHEME_V->code = x;
3448	s_goto (OP_EVAL);	3552	s_goto (OP_EVAL);
3449	}	3553	}
3450	}	3554	}
3451	else	3555
3452	s_return (SCHEME_V->code);	3556	s_return (SCHEME_V->code);
3453		3557
3454	case OP_E0ARGS: /* eval arguments */	3558	case OP_E0ARGS: /* eval arguments */
3455	if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */	3559	if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3456	{	3560	{
3457	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);	3561	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
…		…
3629	else	3733	else
3630	new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);	3734	new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3631		3735
3632	s_return (SCHEME_V->code);	3736	s_return (SCHEME_V->code);
3633		3737
3634
3635	case OP_DEFP: /* defined? */	3738	case OP_DEFP: /* defined? */
3636	x = SCHEME_V->envir;	3739	x = SCHEME_V->envir;
3637		3740
3638	if (cdr (args) != NIL)	3741	if (cdr (args) != NIL)
3639	x = cadr (args);	3742	x = cadr (args);
…		…
3656	set_slot_in_env (SCHEME_A_ y, SCHEME_V->value);	3759	set_slot_in_env (SCHEME_A_ y, SCHEME_V->value);
3657	s_return (SCHEME_V->value);	3760	s_return (SCHEME_V->value);
3658	}	3761	}
3659	else	3762	else
3660	Error_1 ("set!: unbound variable:", SCHEME_V->code);	3763	Error_1 ("set!: unbound variable:", SCHEME_V->code);
3661
3662		3764
3663	case OP_BEGIN: /* begin */	3765	case OP_BEGIN: /* begin */
3664	if (!is_pair (SCHEME_V->code))	3766	if (!is_pair (SCHEME_V->code))
3665	s_return (SCHEME_V->code);	3767	s_return (SCHEME_V->code);
3666		3768
…		…
3678	case OP_IF1: /* if */	3780	case OP_IF1: /* if */
3679	if (is_true (SCHEME_V->value))	3781	if (is_true (SCHEME_V->value))
3680	SCHEME_V->code = car (SCHEME_V->code);	3782	SCHEME_V->code = car (SCHEME_V->code);
3681	else	3783	else
3682	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */	3784	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
		3785
3683	s_goto (OP_EVAL);	3786	s_goto (OP_EVAL);
3684		3787
3685	case OP_LET0: /* let */	3788	case OP_LET0: /* let */
3686	SCHEME_V->args = NIL;	3789	SCHEME_V->args = NIL;
3687	SCHEME_V->value = SCHEME_V->code;	3790	SCHEME_V->value = SCHEME_V->code;
…		…
3843	}	3946	}
3844	else	3947	else
3845	{	3948	{
3846	if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)	3949	if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3847	s_return (NIL);	3950	s_return (NIL);
3848	else	3951
3849	{
3850	s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);	3952	s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3851	SCHEME_V->code = caar (SCHEME_V->code);	3953	SCHEME_V->code = caar (SCHEME_V->code);
3852	s_goto (OP_EVAL);	3954	s_goto (OP_EVAL);
3853	}
3854	}	3955	}
3855		3956
3856	case OP_DELAY: /* delay */	3957	case OP_DELAY: /* delay */
3857	x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);	3958	x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3858	set_typeflag (x, T_PROMISE);	3959	set_typeflag (x, T_PROMISE);
…		…
3869	case OP_AND1: /* and */	3970	case OP_AND1: /* and */
3870	if (is_false (SCHEME_V->value))	3971	if (is_false (SCHEME_V->value))
3871	s_return (SCHEME_V->value);	3972	s_return (SCHEME_V->value);
3872	else if (SCHEME_V->code == NIL)	3973	else if (SCHEME_V->code == NIL)
3873	s_return (SCHEME_V->value);	3974	s_return (SCHEME_V->value);
3874	else	3975
3875	{
3876	s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));	3976	s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3877	SCHEME_V->code = car (SCHEME_V->code);	3977	SCHEME_V->code = car (SCHEME_V->code);
3878	s_goto (OP_EVAL);	3978	s_goto (OP_EVAL);
3879	}
3880		3979
3881	case OP_OR0: /* or */	3980	case OP_OR0: /* or */
3882	if (SCHEME_V->code == NIL)	3981	if (SCHEME_V->code == NIL)
3883	s_return (S_F);	3982	s_return (S_F);
3884		3983
…		…
3889	case OP_OR1: /* or */	3988	case OP_OR1: /* or */
3890	if (is_true (SCHEME_V->value))	3989	if (is_true (SCHEME_V->value))
3891	s_return (SCHEME_V->value);	3990	s_return (SCHEME_V->value);
3892	else if (SCHEME_V->code == NIL)	3991	else if (SCHEME_V->code == NIL)
3893	s_return (SCHEME_V->value);	3992	s_return (SCHEME_V->value);
3894	else	3993
3895	{
3896	s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));	3994	s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3897	SCHEME_V->code = car (SCHEME_V->code);	3995	SCHEME_V->code = car (SCHEME_V->code);
3898	s_goto (OP_EVAL);	3996	s_goto (OP_EVAL);
3899	}
3900		3997
3901	case OP_C0STREAM: /* cons-stream */	3998	case OP_C0STREAM: /* cons-stream */
3902	s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));	3999	s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3903	SCHEME_V->code = car (SCHEME_V->code);	4000	SCHEME_V->code = car (SCHEME_V->code);
3904	s_goto (OP_EVAL);	4001	s_goto (OP_EVAL);
…		…
3969	s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));	4066	s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3970	SCHEME_V->code = caar (x);	4067	SCHEME_V->code = caar (x);
3971	s_goto (OP_EVAL);	4068	s_goto (OP_EVAL);
3972	}	4069	}
3973	}	4070	}
3974	else	4071
3975	s_return (NIL);	4072	s_return (NIL);
3976		4073
3977	case OP_CASE2: /* case */	4074	case OP_CASE2: /* case */
3978	if (is_true (SCHEME_V->value))	4075	if (is_true (SCHEME_V->value))
3979	s_goto (OP_BEGIN);	4076	s_goto (OP_BEGIN);
3980	else	4077
3981	s_return (NIL);	4078	s_return (NIL);
3982		4079
3983	case OP_PAPPLY: /* apply */	4080	case OP_PAPPLY: /* apply */
3984	SCHEME_V->code = car (args);	4081	SCHEME_V->code = car (args);
3985	SCHEME_V->args = list_star (SCHEME_A_ cdr (args));	4082	SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3986	/SCHEME_V->args = cadr(args); /	4083	/SCHEME_V->args = cadr(args); /
…		…
4636	else	4733	else
4637	SCHEME_V->print_flag = 0;	4734	SCHEME_V->print_flag = 0;
4638		4735
4639	s_goto (OP_P0LIST);	4736	s_goto (OP_P0LIST);
4640		4737
		4738	//TODO: move to scheme
4641	case OP_NEWLINE: /* newline */	4739	case OP_NEWLINE: /* newline */
4642	if (is_pair (args))	4740	if (is_pair (args))
4643	{	4741	{
4644	if (a != SCHEME_V->outport)	4742	if (a != SCHEME_V->outport)
4645	{	4743	{
…		…
4647	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);	4745	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4648	SCHEME_V->outport = a;	4746	SCHEME_V->outport = a;
4649	}	4747	}
4650	}	4748	}
4651		4749
4652	putstr (SCHEME_A_ "\n");	4750	putcharacter (SCHEME_A_ '\n');
4653	s_return (S_T);	4751	s_return (S_T);
4654	#endif	4752	#endif
4655		4753
4656	case OP_ERR0: /* error */	4754	case OP_ERR0: /* error */
4657	SCHEME_V->retcode = -1;	4755	SCHEME_V->retcode = -1;
…		…
4666	putstr (SCHEME_A_ strvalue (car (args)));	4764	putstr (SCHEME_A_ strvalue (car (args)));
4667	SCHEME_V->args = cdr (args);	4765	SCHEME_V->args = cdr (args);
4668	s_goto (OP_ERR1);	4766	s_goto (OP_ERR1);
4669		4767
4670	case OP_ERR1: /* error */	4768	case OP_ERR1: /* error */
4671	putstr (SCHEME_A_ " ");	4769	putcharacter (SCHEME_A_ ' ');
4672		4770
4673	if (args != NIL)	4771	if (args != NIL)
4674	{	4772	{
4675	s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);	4773	s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4676	SCHEME_V->args = a;	4774	SCHEME_V->args = a;
4677	SCHEME_V->print_flag = 1;	4775	SCHEME_V->print_flag = 1;
4678	s_goto (OP_P0LIST);	4776	s_goto (OP_P0LIST);
4679	}	4777	}
4680	else	4778	else
4681	{	4779	{
4682	putstr (SCHEME_A_ "\n");	4780	putcharacter (SCHEME_A_ '\n');
4683		4781
4684	if (SCHEME_V->interactive_repl)	4782	if (SCHEME_V->interactive_repl)
4685	s_goto (OP_T0LVL);	4783	s_goto (OP_T0LVL);
4686	else	4784	else
4687	return -1;	4785	return -1;
…		…
5175	pointer b = cdr (args);	5273	pointer b = cdr (args);
5176	int ok_abbr = ok_abbrev (b);	5274	int ok_abbr = ok_abbrev (b);
5177	SCHEME_V->args = car (b);	5275	SCHEME_V->args = car (b);
5178		5276
5179	if (a == SCHEME_V->QUOTE && ok_abbr)	5277	if (a == SCHEME_V->QUOTE && ok_abbr)
5180	putstr (SCHEME_A_ "'");	5278	putcharacter (SCHEME_A_ '\'');
5181	else if (a == SCHEME_V->QQUOTE && ok_abbr)	5279	else if (a == SCHEME_V->QQUOTE && ok_abbr)
5182	putstr (SCHEME_A_ "`");	5280	putcharacter (SCHEME_A_ '`');
5183	else if (a == SCHEME_V->UNQUOTE && ok_abbr)	5281	else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5184	putstr (SCHEME_A_ ",");	5282	putcharacter (SCHEME_A_ ',');
5185	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)	5283	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5186	putstr (SCHEME_A_ ",@");	5284	putstr (SCHEME_A_ ",@");
5187	else	5285	else
5188	{	5286	{
5189	putstr (SCHEME_A_ "(");	5287	putcharacter (SCHEME_A_ '(');
5190	s_save (SCHEME_A_ OP_P1LIST, b, NIL);	5288	s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5191	SCHEME_V->args = a;	5289	SCHEME_V->args = a;
5192	}	5290	}
5193		5291
5194	s_goto (OP_P0LIST);	5292	s_goto (OP_P0LIST);
…		…
5196		5294
5197	case OP_P1LIST:	5295	case OP_P1LIST:
5198	if (is_pair (args))	5296	if (is_pair (args))
5199	{	5297	{
5200	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);	5298	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5201	putstr (SCHEME_A_ " ");	5299	putcharacter (SCHEME_A_ ' ');
5202	SCHEME_V->args = car (args);	5300	SCHEME_V->args = car (args);
5203	s_goto (OP_P0LIST);	5301	s_goto (OP_P0LIST);
5204	}	5302	}
5205	else if (is_vector (args))	5303	else if (is_vector (args))
5206	{	5304	{
…		…
5214	{	5312	{
5215	putstr (SCHEME_A_ " . ");	5313	putstr (SCHEME_A_ " . ");
5216	printatom (SCHEME_A_ args, SCHEME_V->print_flag);	5314	printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5217	}	5315	}
5218		5316
5219	putstr (SCHEME_A_ ")");	5317	putcharacter (SCHEME_A_ ')');
5220	s_return (S_T);	5318	s_return (S_T);
5221	}	5319	}
5222		5320
5223	case OP_PVECFROM:	5321	case OP_PVECFROM:
5224	{	5322	{
…		…
5226	pointer vec = car (args);	5324	pointer vec = car (args);
5227	int len = veclength (vec);	5325	int len = veclength (vec);
5228		5326
5229	if (i == len)	5327	if (i == len)
5230	{	5328	{
5231	putstr (SCHEME_A_ ")");	5329	putcharacter (SCHEME_A_ ')');
5232	s_return (S_T);	5330	s_return (S_T);
5233	}	5331	}
5234	else	5332	else
5235	{	5333	{
5236	pointer elem = vector_get (vec, i);	5334	pointer elem = vector_get (vec, i);
…		…
5238	ivalue_unchecked (cdr (args)) = i + 1;	5336	ivalue_unchecked (cdr (args)) = i + 1;
5239	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);	5337	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5240	SCHEME_V->args = elem;	5338	SCHEME_V->args = elem;
5241		5339
5242	if (i > 0)	5340	if (i > 0)
5243	putstr (SCHEME_A_ " ");	5341	putcharacter (SCHEME_A_ ' ');
5244		5342
5245	s_goto (OP_P0LIST);	5343	s_goto (OP_P0LIST);
5246	}	5344	}
5247	}	5345	}
5248	}	5346	}
…		…
5678	#endif	5776	#endif
5679	}	5777	}
5680		5778
5681	SCHEME_V->gc_verbose = 0;	5779	SCHEME_V->gc_verbose = 0;
5682	dump_stack_initialize (SCHEME_A);	5780	dump_stack_initialize (SCHEME_A);
5683	SCHEME_V->code = NIL;	5781	SCHEME_V->code = NIL;
5684	SCHEME_V->args = NIL;	5782	SCHEME_V->args = NIL;
5685	SCHEME_V->envir = NIL;	5783	SCHEME_V->envir = NIL;
		5784	SCHEME_V->value = NIL;
5686	SCHEME_V->tracing = 0;	5785	SCHEME_V->tracing = 0;
5687		5786
5688	/* init NIL */	5787	/* init NIL */
5689	set_typeflag (NIL, T_ATOM \| T_MARK);	5788	set_typeflag (NIL, T_ATOM \| T_MARK);
5690	set_car (NIL, NIL);	5789	set_car (NIL, NIL);
…		…
5844	SCHEME_V->envir = SCHEME_V->global_env;	5943	SCHEME_V->envir = SCHEME_V->global_env;
5845	SCHEME_V->file_i = 0;	5944	SCHEME_V->file_i = 0;
5846	SCHEME_V->load_stack[0].unget = -1;	5945	SCHEME_V->load_stack[0].unget = -1;
5847	SCHEME_V->load_stack[0].kind = port_input \| port_file;	5946	SCHEME_V->load_stack[0].kind = port_input \| port_file;
5848	SCHEME_V->load_stack[0].rep.stdio.file = fin;	5947	SCHEME_V->load_stack[0].rep.stdio.file = fin;
5849	#if USE_PORTS
5850	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);	5948	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5851	#endif
5852	SCHEME_V->retcode = 0;	5949	SCHEME_V->retcode = 0;
5853		5950
5854	#if USE_PORTS
5855	if (fin == STDIN_FILENO)	5951	if (fin == STDIN_FILENO)
5856	SCHEME_V->interactive_repl = 1;	5952	SCHEME_V->interactive_repl = 1;
5857	#endif
5858		5953
5859	#if USE_PORTS	5954	#if USE_PORTS
5860	#if SHOW_ERROR_LINE	5955	#if SHOW_ERROR_LINE
5861	SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;	5956	SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5862		5957
…		…
5866	#endif	5961	#endif
5867		5962
5868	SCHEME_V->inport = SCHEME_V->loadport;	5963	SCHEME_V->inport = SCHEME_V->loadport;
5869	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	5964	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5870	Eval_Cycle (SCHEME_A_ OP_T0LVL);	5965	Eval_Cycle (SCHEME_A_ OP_T0LVL);
		5966
5871	set_typeflag (SCHEME_V->loadport, T_ATOM);	5967	set_typeflag (SCHEME_V->loadport, T_ATOM);
5872		5968
5873	if (SCHEME_V->retcode == 0)	5969	if (SCHEME_V->retcode == 0)
5874	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5970	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5875	}	5971	}
5876		5972
5877	ecb_cold void	5973	ecb_cold void
5878	scheme_load_string (SCHEME_P_ const char *cmd)	5974	scheme_load_string (SCHEME_P_ const char *cmd)
5879	{	5975	{
		5976	#if USE_PORTs
5880	dump_stack_reset (SCHEME_A);	5977	dump_stack_reset (SCHEME_A);
5881	SCHEME_V->envir = SCHEME_V->global_env;	5978	SCHEME_V->envir = SCHEME_V->global_env;
5882	SCHEME_V->file_i = 0;	5979	SCHEME_V->file_i = 0;
5883	SCHEME_V->load_stack[0].kind = port_input \| port_string;	5980	SCHEME_V->load_stack[0].kind = port_input \| port_string;
5884	SCHEME_V->load_stack[0].rep.string.start = (char )cmd; / This func respects const */	5981	SCHEME_V->load_stack[0].rep.string.start = (char )cmd; / This func respects const */
5885	SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);	5982	SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5886	SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;	5983	SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5887	#if USE_PORTS
5888	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);	5984	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5889	#endif
5890	SCHEME_V->retcode = 0;	5985	SCHEME_V->retcode = 0;
5891	SCHEME_V->interactive_repl = 0;	5986	SCHEME_V->interactive_repl = 0;
5892	SCHEME_V->inport = SCHEME_V->loadport;	5987	SCHEME_V->inport = SCHEME_V->loadport;
5893	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	5988	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5894	Eval_Cycle (SCHEME_A_ OP_T0LVL);	5989	Eval_Cycle (SCHEME_A_ OP_T0LVL);
5895	set_typeflag (SCHEME_V->loadport, T_ATOM);	5990	set_typeflag (SCHEME_V->loadport, T_ATOM);
5896		5991
5897	if (SCHEME_V->retcode == 0)	5992	if (SCHEME_V->retcode == 0)
5898	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5993	SCHEME_V->retcode = SCHEME_V->nesting != 0;
		5994	#else
		5995	abort ();
		5996	#endif
5899	}	5997	}
5900		5998
5901	ecb_cold void	5999	ecb_cold void
5902	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)	6000	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5903	{	6001	{
…		…
6047	}	6145	}
6048	#endif	6146	#endif
6049		6147
6050	do	6148	do
6051	{	6149	{
6052	#if USE_PORTS
6053	if (strcmp (file_name, "-") == 0)	6150	if (strcmp (file_name, "-") == 0)
6054	fin = STDIN_FILENO;	6151	fin = STDIN_FILENO;
6055	else if (strcmp (file_name, "-1") == 0 \|\| strcmp (file_name, "-c") == 0)	6152	else if (strcmp (file_name, "-1") == 0 \|\| strcmp (file_name, "-c") == 0)
6056	{	6153	{
6057	pointer args = NIL;	6154	pointer args = NIL;
…		…
6075	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "args"), args);	6172	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "args"), args);
6076		6173
6077	}	6174	}
6078	else	6175	else
6079	fin = open (file_name, O_RDONLY);	6176	fin = open (file_name, O_RDONLY);
6080	#endif
6081		6177
6082	if (isfile && fin < 0)	6178	if (isfile && fin < 0)
6083	{	6179	{
6084	putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");	6180	putstr (SCHEME_A_ "Could not open file ");
		6181	putstr (SCHEME_A_ file_name);
		6182	putcharacter (SCHEME_A_ '\n');
6085	}	6183	}
6086	else	6184	else
6087	{	6185	{
6088	if (isfile)	6186	if (isfile)
6089	scheme_load_named_file (SCHEME_A_ fin, file_name);	6187	scheme_load_named_file (SCHEME_A_ fin, file_name);
6090	else	6188	else
6091	scheme_load_string (SCHEME_A_ file_name);	6189	scheme_load_string (SCHEME_A_ file_name);
6092		6190
6093	#if USE_PORTS
6094	if (!isfile \|\| fin != STDIN_FILENO)	6191	if (!isfile \|\| fin != STDIN_FILENO)
6095	{	6192	{
6096	if (SCHEME_V->retcode != 0)	6193	if (SCHEME_V->retcode != 0)
6097	{	6194	{
6098	putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");	6195	putstr (SCHEME_A_ "Errors encountered reading ");
		6196	putstr (SCHEME_A_ file_name);
		6197	putcharacter (SCHEME_A_ '\n');
6099	}	6198	}
6100		6199
6101	if (isfile)	6200	if (isfile)
6102	close (fin);	6201	close (fin);
6103	}	6202	}
6104	#endif
6105	}	6203	}
6106		6204
6107	file_name = *argv++;	6205	file_name = *argv++;
6108	}	6206	}
6109	while (file_name != 0);	6207	while (file_name != 0);

Diff Legend

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

Comparing microscheme/scheme.c (file contents): Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC vs. Revision 1.61 by root, Wed Dec 2 07:43:46 2015 UTC

Diff Legend

Comparing microscheme/scheme.c (file contents):
Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC vs.
Revision 1.61 by root, Wed Dec 2 07:43:46 2015 UTC