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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC vs.
Revision 1.62 by root, Wed Dec 2 07:59:15 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);
696	static char readstr_upto (SCHEME_P_ int skip, const char delim);	710	static char readstr_upto (SCHEME_P_ int skip, const char delim);
697	static pointer readstrexp (SCHEME_P_ char delim);	711	static pointer readstrexp (SCHEME_P_ char delim);
698	ecb_inline int skipspace (SCHEME_P);	712	static int skipspace (SCHEME_P);
699	static int token (SCHEME_P);	713	static int token (SCHEME_P);
700	static void printslashstring (SCHEME_P_ char *s, int len);	714	static void printslashstring (SCHEME_P_ char *s, int len);
701	static void atom2str (SCHEME_P_ pointer l, int f, char *pp, int plen);	715	static void atom2str (SCHEME_P_ pointer l, int f, char *pp, int plen);
702	static void printatom (SCHEME_P_ pointer l, int f);	716	static void printatom (SCHEME_P_ pointer l, int f);
703	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	717	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
902		916
903	if (!cp && USE_ERROR_CHECKING)	917	if (!cp && USE_ERROR_CHECKING)
904	return k;	918	return k;
905		919
906	i = ++SCHEME_V->last_cell_seg;	920	i = ++SCHEME_V->last_cell_seg;
907	SCHEME_V->alloc_seg[i] = cp;
908		921
909	newp = (struct cell *)cp;	922	newp = (struct cell *)cp;
910	SCHEME_V->cell_seg[i] = newp;	923	SCHEME_V->cell_seg[i] = newp;
911	SCHEME_V->cell_segsize[i] = segsize;	924	SCHEME_V->cell_segsize[i] = segsize;
912	SCHEME_V->fcells += segsize;	925	SCHEME_V->fcells += segsize;
…		…
935	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	948	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
936	return S_SINK;	949	return S_SINK;
937		950
938	if (SCHEME_V->free_cell == NIL)	951	if (SCHEME_V->free_cell == NIL)
939	{	952	{
940	const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1;	953	const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
941		954
942	gc (SCHEME_A_ a, b);	955	gc (SCHEME_A_ a, b);
943		956
944	if (SCHEME_V->fcells < min_to_be_recovered \|\| SCHEME_V->free_cell == NIL)	957	if (SCHEME_V->fcells < min_to_be_recovered \|\| SCHEME_V->free_cell == NIL)
945	{	958	{
…		…
1043	#endif	1056	#endif
1044		1057
1045	/* Medium level cell allocation */	1058	/* Medium level cell allocation */
1046		1059
1047	/* get new cons cell */	1060	/* get new cons cell */
1048	ecb_hot pointer	1061	ecb_hot static pointer
1049	xcons (SCHEME_P_ pointer a, pointer b, int immutable)	1062	xcons (SCHEME_P_ pointer a, pointer b)
1050	{	1063	{
1051	pointer x = get_cell (SCHEME_A_ a, b);	1064	pointer x = get_cell (SCHEME_A_ a, b);
1052		1065
1053	set_typeflag (x, T_PAIR);	1066	set_typeflag (x, T_PAIR);
1054
1055	if (immutable)
1056	setimmutable (x);
1057		1067
1058	set_car (x, a);	1068	set_car (x, a);
1059	set_cdr (x, b);	1069	set_cdr (x, b);
1060		1070
1061	return x;	1071	return x;
1062	}	1072	}
		1073
		1074	ecb_hot static pointer
		1075	ximmutable_cons (SCHEME_P_ pointer a, pointer b)
		1076	{
		1077	pointer x = xcons (SCHEME_A_ a, b);
		1078	setimmutable (x);
		1079	return x;
		1080	}
		1081
		1082	#define cons(a,b) xcons (SCHEME_A_ a, b)
		1083	#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1063		1084
1064	ecb_cold static pointer	1085	ecb_cold static pointer
1065	generate_symbol (SCHEME_P_ const char *name)	1086	generate_symbol (SCHEME_P_ const char *name)
1066	{	1087	{
1067	pointer x = mk_string (SCHEME_A_ name);	1088	pointer x = mk_string (SCHEME_A_ name);
…		…
1075	#ifndef USE_OBJECT_LIST	1096	#ifndef USE_OBJECT_LIST
1076		1097
1077	static int	1098	static int
1078	hash_fn (const char *key, int table_size)	1099	hash_fn (const char *key, int table_size)
1079	{	1100	{
1080	const unsigned char *p = key;	1101	const unsigned char p = (unsigned char )key;
1081	uint32_t hash = 2166136261;	1102	uint32_t hash = 2166136261;
1082		1103
1083	while (*p)	1104	while (*p)
1084	hash = (hash ^ p++) 16777619;	1105	hash = (hash ^ p++) 16777619;
1085		1106
…		…
1178	return SCHEME_V->oblist;	1199	return SCHEME_V->oblist;
1179	}	1200	}
1180		1201
1181	#endif	1202	#endif
1182		1203
1183	#if USE_PORTS
1184	ecb_cold static pointer	1204	ecb_cold static pointer
1185	mk_port (SCHEME_P_ port *p)	1205	mk_port (SCHEME_P_ port *p)
1186	{	1206	{
1187	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1207	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1188		1208
1189	set_typeflag (x, T_PORT \| T_ATOM);	1209	set_typeflag (x, T_PORT \| T_ATOM);
1190	set_port (x, p);	1210	set_port (x, p);
1191		1211
1192	return x;	1212	return x;
1193	}	1213	}
1194	#endif
1195		1214
1196	ecb_cold pointer	1215	ecb_cold pointer
1197	mk_foreign_func (SCHEME_P_ foreign_func f)	1216	mk_foreign_func (SCHEME_P_ foreign_func f)
1198	{	1217	{
1199	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1218	pointer x = get_cell (SCHEME_A_ NIL, NIL);
…		…
1722	/* ========== Routines for Reading ========== */	1741	/* ========== Routines for Reading ========== */
1723		1742
1724	ecb_cold static int	1743	ecb_cold static int
1725	file_push (SCHEME_P_ const char *fname)	1744	file_push (SCHEME_P_ const char *fname)
1726	{	1745	{
1727	#if USE_PORTS
1728	int fin;	1746	int fin;
1729		1747
1730	if (SCHEME_V->file_i == MAXFIL - 1)	1748	if (SCHEME_V->file_i == MAXFIL - 1)
1731	return 0;	1749	return 0;
1732		1750
…		…
1749	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);	1767	SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1750	#endif	1768	#endif
1751	}	1769	}
1752		1770
1753	return fin >= 0;	1771	return fin >= 0;
1754
1755	#else
1756	return 1;
1757	#endif
1758	}	1772	}
1759		1773
1760	ecb_cold static void	1774	ecb_cold static void
1761	file_pop (SCHEME_P)	1775	file_pop (SCHEME_P)
1762	{	1776	{
…		…
1946	}	1960	}
1947	}	1961	}
1948	#endif	1962	#endif
1949		1963
1950	/* get new character from input file */	1964	/* get new character from input file */
1951	static int	1965	ecb_cold static int
1952	inchar (SCHEME_P)	1966	inchar (SCHEME_P)
1953	{	1967	{
1954	int c;	1968	int c;
1955	port *pt = port (SCHEME_V->inport);	1969	port *pt = port (SCHEME_V->inport);
1956		1970
…		…
1970	}	1984	}
1971		1985
1972	return c;	1986	return c;
1973	}	1987	}
1974		1988
1975	static int ungot = -1;	1989	ecb_cold static int
1976
1977	static int
1978	basic_inchar (port *pt)	1990	basic_inchar (port *pt)
1979	{	1991	{
1980	#if USE_PORTS
1981	if (pt->unget != -1)	1992	if (pt->unget != -1)
1982	{	1993	{
1983	int r = pt->unget;	1994	int r = pt->unget;
1984	pt->unget = -1;	1995	pt->unget = -1;
1985	return r;	1996	return r;
1986	}	1997	}
1987		1998
		1999	#if USE_PORTS
1988	if (pt->kind & port_file)	2000	if (pt->kind & port_file)
1989	{	2001	{
1990	char c;	2002	char c;
1991		2003
1992	if (!read (pt->rep.stdio.file, &c, 1))	2004	if (!read (pt->rep.stdio.file, &c, 1))
…		…
2000	return EOF;	2012	return EOF;
2001	else	2013	else
2002	return *pt->rep.string.curr++;	2014	return *pt->rep.string.curr++;
2003	}	2015	}
2004	#else	2016	#else
2005	if (ungot == -1)
2006	{
2007	char c;	2017	char c;
2008	if (!read (0, &c, 1))	2018
		2019	if (!read (pt->rep.stdio.file, &c, 1))
2009	return EOF;	2020	return EOF;
2010		2021
2011	ungot = c;
2012	}
2013
2014	{
2015	int r = ungot;
2016	ungot = -1;
2017	return r;	2022	return c;
2018	}
2019	#endif	2023	#endif
2020	}	2024	}
2021		2025
2022	/* back character to input buffer */	2026	/* back character to input buffer */
2023	static void	2027	ecb_cold static void
2024	backchar (SCHEME_P_ int c)	2028	backchar (SCHEME_P_ int c)
2025	{	2029	{
2026	#if USE_PORTS	2030	port *pt = port (SCHEME_V->inport);
2027	port *pt;
2028		2031
2029	if (c == EOF)	2032	if (c == EOF)
2030	return;	2033	return;
2031		2034
2032	pt = port (SCHEME_V->inport);
2033	pt->unget = c;	2035	pt->unget = c;
2034	#else
2035	if (c == EOF)
2036	return;
2037
2038	ungot = c;
2039	#endif
2040	}	2036	}
2041		2037
2042	#if USE_PORTS	2038	#if USE_PORTS
2043	ecb_cold static int	2039	ecb_cold static int
2044	realloc_port_string (SCHEME_P_ port *p)	2040	realloc_port_string (SCHEME_P_ port *p)
…		…
2061	else	2057	else
2062	return 0;	2058	return 0;
2063	}	2059	}
2064	#endif	2060	#endif
2065		2061
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	2062	ecb_cold static void
2087	putchars (SCHEME_P_ const char *s, int len)	2063	putchars (SCHEME_P_ const char *s, int len)
2088	{	2064	{
		2065	port *pt = port (SCHEME_V->outport);
		2066
2089	#if USE_PORTS	2067	#if USE_PORTS
2090	port *pt = port (SCHEME_V->outport);
2091
2092	if (pt->kind & port_file)	2068	if (pt->kind & port_file)
2093	write (pt->rep.stdio.file, s, len);	2069	write (pt->rep.stdio.file, s, len);
2094	else	2070	else
2095	{	2071	{
2096	for (; len; len--)	2072	for (; len; len--)
…		…
2101	pt->rep.string.curr++ = s++;	2077	pt->rep.string.curr++ = s++;
2102	}	2078	}
2103	}	2079	}
2104		2080
2105	#else	2081	#else
2106	write (1, s, len);	2082	write (1, s, len); // output not initialised
2107	#endif	2083	#endif
2108	}	2084	}
2109		2085
2110	ecb_cold INTERFACE void	2086	INTERFACE void
		2087	putstr (SCHEME_P_ const char *s)
		2088	{
		2089	putchars (SCHEME_A_ s, strlen (s));
		2090	}
		2091
		2092	INTERFACE void
2111	putcharacter (SCHEME_P_ int c)	2093	putcharacter (SCHEME_P_ int c)
2112	{	2094	{
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;	2095	char cc = c;
2131	write (1, &c, 1);	2096
2132	#endif	2097	putchars (SCHEME_A_ &cc, 1);
2133	}	2098	}
2134		2099
2135	/* read characters up to delimiter, but cater to character constants */	2100	/* read characters up to delimiter, but cater to character constants */
2136	ecb_cold static char *	2101	ecb_cold static char *
2137	readstr_upto (SCHEME_P_ int skip, const char *delim)	2102	readstr_upto (SCHEME_P_ int skip, const char *delim)
…		…
2198	case 'a': *p++ = '\a'; state = st_ok; break;	2163	case 'a': *p++ = '\a'; state = st_ok; break;
2199	case 'n': *p++ = '\n'; state = st_ok; break;	2164	case 'n': *p++ = '\n'; state = st_ok; break;
2200	case 'r': *p++ = '\r'; state = st_ok; break;	2165	case 'r': *p++ = '\r'; state = st_ok; break;
2201	case 't': *p++ = '\t'; state = st_ok; break;	2166	case 't': *p++ = '\t'; state = st_ok; break;
2202		2167
2203	//TODO: \whitespace eol whitespace	2168	// this overshoots the minimum requirements of r7rs
		2169	case ' ':
		2170	case '\t':
		2171	case '\r':
		2172	case '\n':
		2173	skipspace (SCHEME_A);
		2174	state = st_ok;
		2175	break;
2204		2176
2205	//TODO: x should end in ;, not two-digit hex	2177	//TODO: x should end in ;, not two-digit hex
2206	case 'x':	2178	case 'x':
2207	case 'X':	2179	case 'X':
2208	state = st_x1;	2180	state = st_x1;
…		…
3246	#endif	3218	#endif
3247		3219
3248	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3220	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3249		3221
3250	#if EXPERIMENT	3222	#if EXPERIMENT
		3223
		3224	typedef void *stream[1];
		3225
		3226	#define stream_init() { 0 }
		3227
		3228	ecb_cold static void
		3229	stream_put (void **s, uint8_t byte)
		3230	{
		3231	uint32_t sp = s;
		3232	uint32_t size = sizeof (uint32_t) * 2;
		3233	uint32_t offs = size;
		3234
		3235	if (ecb_expect_true (sp))
		3236	{
		3237	offs = sp[0];
		3238	size = sp[1];
		3239	}
		3240
		3241	if (ecb_expect_false (offs == size))
		3242	{
		3243	size *= 2;
		3244	sp = realloc (sp, size);
		3245	*s = sp;
		3246	sp[1] = size;
		3247
		3248	}
		3249
		3250	((uint8_t *)sp)[offs++] = byte;
		3251	sp[0] = offs;
		3252	}
		3253
		3254	#define stream_data(s) ((char )(s)[0] + sizeof (uint32_t) 2)
		3255	#define stream_size(s) (((uint32_t )(s)[0])[0] - sizeof (uint32_t) 2)
		3256	#define stream_free(s) free (s[0])
		3257
		3258	// calculates a (preferably small) integer that makes it possible to find
		3259	// the symbol again. if pointers were offsets into a memory area... until
		3260	// then, we return segment number in the low bits, and offset in the high
		3261	// bits
		3262	static uint32_t
		3263	symbol_id (SCHEME_P_ pointer sym)
		3264	{
		3265	struct cell *p = CELL (sym);
		3266	int i;
		3267
		3268	for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
		3269	if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
		3270	{
		3271	printf ("seg %d ofs %d/%d\n",i,(p - SCHEME_V->cell_seg[i]),SCHEME_V->cell_segsize[i]);//D
		3272	return i \| ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
		3273	}
		3274
		3275	abort ();
		3276	}
		3277
		3278	static void
		3279	compile (SCHEME_P_ stream s, pointer x)
		3280	{
		3281	if (x == NIL)
		3282	{
		3283	stream_put (s, 0);
		3284	return;
		3285	}
		3286
		3287	if (is_syntax (x))
		3288	{
		3289	stream_put (s, 1);
		3290	stream_put (s, syntaxnum (x));
		3291	return;
		3292	}
		3293
		3294	switch (type (x))
		3295	{
		3296	case T_INTEGER:
		3297	stream_put (s, 2);
		3298	stream_put (s, 0);
		3299	stream_put (s, 0);
		3300	stream_put (s, 0);
		3301	stream_put (s, 0);
		3302	return;
		3303
		3304	case T_SYMBOL:
		3305	{
		3306	uint32_t sym = symbol_id (SCHEME_A_ x);
		3307	printf ("sym %x\n", sym);//D
		3308
		3309	stream_put (s, 3);
		3310
		3311	while (sym > 0x7f)
		3312	{
		3313	stream_put (s, sym \| 0x80);
		3314	sym >>= 8;
		3315	}
		3316
		3317	stream_put (s, sym);
		3318	}
		3319	return;
		3320
		3321	case T_PAIR:
		3322	stream_put (s, 4);
		3323	while (x != NIL)
		3324	{
		3325	compile (SCHEME_A_ s, car (x));
		3326	x = cdr (x);
		3327	}
		3328	stream_put (s, 0xff);
		3329	return;
		3330
		3331	default:
		3332	stream_put (s, 5);
		3333	stream_put (s, type (x));
		3334	stream_put (s, 0);
		3335	stream_put (s, 0);
		3336	stream_put (s, 0);
		3337	stream_put (s, 0);
		3338	break;
		3339	}
		3340	}
		3341
3251	static int	3342	static int
		3343	compile_closure (SCHEME_P_ pointer p)
		3344	{
		3345	stream s = stream_init ();
		3346
		3347	printatom (SCHEME_A_ p, 1);//D
		3348	compile (SCHEME_A_ s, car (p));
		3349
		3350	FILE *xxd = popen ("xxd", "we");
		3351	fwrite (stream_data (s), 1, stream_size (s), xxd);
		3352	fclose (xxd);
		3353
		3354	return stream_size (s);
		3355	}
		3356
		3357	static int
3252	debug (SCHEME_P_ int indent, pointer x)	3358	dtree (SCHEME_P_ int indent, pointer x)
3253	{	3359	{
3254	int c;	3360	int c;
3255		3361
3256	if (is_syntax (x))	3362	if (is_syntax (x))
3257	{	3363	{
…		…
3275	printf ("%*sS<%s>\n", indent, "", symname (x));	3381	printf ("%*sS<%s>\n", indent, "", symname (x));
3276	return 24+8;	3382	return 24+8;
3277		3383
3278	case T_CLOSURE:	3384	case T_CLOSURE:
3279	printf ("%*sS<%s>\n", indent, "", "closure");	3385	printf ("%*sS<%s>\n", indent, "", "closure");
3280	debug (SCHEME_A_ indent + 3, cdr(x));	3386	dtree (SCHEME_A_ indent + 3, cdr(x));
3281	return 32 + debug (SCHEME_A_ indent + 3, car (x));	3387	return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3282		3388
3283	case T_PAIR:	3389	case T_PAIR:
3284	printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));	3390	printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3285	c = debug (SCHEME_A_ indent + 3, car (x));	3391	c = dtree (SCHEME_A_ indent + 3, car (x));
3286	c += debug (SCHEME_A_ indent + 3, cdr (x));	3392	c += dtree (SCHEME_A_ indent + 3, cdr (x));
3287	return c + 1;	3393	return c + 1;
3288		3394
3289	case T_PORT:	3395	case T_PORT:
3290	printf ("%*sS<%s>\n", indent, "", "port");	3396	printf ("%*sS<%s>\n", indent, "", "port");
3291	return 24+8;	3397	return 24+8;
…		…
3294	printf ("%*sS<%s>\n", indent, "", "vector");	3400	printf ("%*sS<%s>\n", indent, "", "vector");
3295	return 24+8;	3401	return 24+8;
3296		3402
3297	case T_ENVIRONMENT:	3403	case T_ENVIRONMENT:
3298	printf ("%*sS<%s>\n", indent, "", "environment");	3404	printf ("%*sS<%s>\n", indent, "", "environment");
3299	return 0 + debug (SCHEME_A_ indent + 3, car (x));	3405	return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3300		3406
3301	default:	3407	default:
3302	printf ("unhandled type %d\n", type (x));	3408	printf ("unhandled type %d\n", type (x));
3303	break;	3409	break;
3304	}	3410	}
…		…
3314		3420
3315	switch (op)	3421	switch (op)
3316	{	3422	{
3317	#if EXPERIMENT //D	3423	#if EXPERIMENT //D
3318	case OP_DEBUG:	3424	case OP_DEBUG:
3319	printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);	3425	{
		3426	uint32_t len = compile_closure (SCHEME_A_ car (args));
		3427	printf ("len = %d\n", len);
3320	printf ("\n");	3428	printf ("\n");
3321	s_return (S_T);	3429	s_return (S_T);
		3430	}
3322	#endif	3431	#endif
3323	case OP_LOAD: /* load */	3432	case OP_LOAD: /* load */
3324	if (file_interactive (SCHEME_A))	3433	if (file_interactive (SCHEME_A))
3325	{	3434	{
3326	putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");	3435	putstr (SCHEME_A_ "Loading ");
3327	//D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));	3436	putstr (SCHEME_A_ strvalue (car (args)));
		3437	putcharacter (SCHEME_A_ '\n');
3328	}	3438	}
3329		3439
3330	if (!file_push (SCHEME_A_ strvalue (car (args))))	3440	if (!file_push (SCHEME_A_ strvalue (car (args))))
3331	Error_1 ("unable to open", car (args));	3441	Error_1 ("unable to open", car (args));
3332	else	3442
3333	{
3334	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	3443	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3335	s_goto (OP_T0LVL);	3444	s_goto (OP_T0LVL);
3336	}
3337		3445
3338	case OP_T0LVL: /* top level */	3446	case OP_T0LVL: /* top level */
3339		3447
3340	/* If we reached the end of file, this loop is done. */	3448	/* If we reached the end of file, this loop is done. */
3341	if (port (SCHEME_V->loadport)->kind & port_saw_EOF)	3449	if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
…		…
3357	/* If interactive, be nice to user. */	3465	/* If interactive, be nice to user. */
3358	if (file_interactive (SCHEME_A))	3466	if (file_interactive (SCHEME_A))
3359	{	3467	{
3360	SCHEME_V->envir = SCHEME_V->global_env;	3468	SCHEME_V->envir = SCHEME_V->global_env;
3361	dump_stack_reset (SCHEME_A);	3469	dump_stack_reset (SCHEME_A);
3362	putstr (SCHEME_A_ "\n");	3470	putcharacter (SCHEME_A_ '\n');
3363	putstr (SCHEME_A_ prompt);	3471	putstr (SCHEME_A_ prompt);
3364	}	3472	}
3365		3473
3366	/* Set up another iteration of REPL */	3474	/* Set up another iteration of REPL */
3367	SCHEME_V->nesting = 0;	3475	SCHEME_V->nesting = 0;
…		…
3402	{	3510	{
3403	SCHEME_V->print_flag = 1;	3511	SCHEME_V->print_flag = 1;
3404	SCHEME_V->args = SCHEME_V->value;	3512	SCHEME_V->args = SCHEME_V->value;
3405	s_goto (OP_P0LIST);	3513	s_goto (OP_P0LIST);
3406	}	3514	}
3407	else	3515
3408	s_return (SCHEME_V->value);	3516	s_return (SCHEME_V->value);
3409		3517
3410	case OP_EVAL: /* main part of evaluation */	3518	case OP_EVAL: /* main part of evaluation */
3411	#if USE_TRACING	3519	#if USE_TRACING
3412	if (SCHEME_V->tracing)	3520	if (SCHEME_V->tracing)
3413	{	3521	{
…		…
3446	/* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */	3554	/* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3447	SCHEME_V->code = x;	3555	SCHEME_V->code = x;
3448	s_goto (OP_EVAL);	3556	s_goto (OP_EVAL);
3449	}	3557	}
3450	}	3558	}
3451	else	3559
3452	s_return (SCHEME_V->code);	3560	s_return (SCHEME_V->code);
3453		3561
3454	case OP_E0ARGS: /* eval arguments */	3562	case OP_E0ARGS: /* eval arguments */
3455	if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */	3563	if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3456	{	3564	{
3457	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);	3565	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
…		…
3629	else	3737	else
3630	new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);	3738	new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3631		3739
3632	s_return (SCHEME_V->code);	3740	s_return (SCHEME_V->code);
3633		3741
3634
3635	case OP_DEFP: /* defined? */	3742	case OP_DEFP: /* defined? */
3636	x = SCHEME_V->envir;	3743	x = SCHEME_V->envir;
3637		3744
3638	if (cdr (args) != NIL)	3745	if (cdr (args) != NIL)
3639	x = cadr (args);	3746	x = cadr (args);
…		…
3656	set_slot_in_env (SCHEME_A_ y, SCHEME_V->value);	3763	set_slot_in_env (SCHEME_A_ y, SCHEME_V->value);
3657	s_return (SCHEME_V->value);	3764	s_return (SCHEME_V->value);
3658	}	3765	}
3659	else	3766	else
3660	Error_1 ("set!: unbound variable:", SCHEME_V->code);	3767	Error_1 ("set!: unbound variable:", SCHEME_V->code);
3661
3662		3768
3663	case OP_BEGIN: /* begin */	3769	case OP_BEGIN: /* begin */
3664	if (!is_pair (SCHEME_V->code))	3770	if (!is_pair (SCHEME_V->code))
3665	s_return (SCHEME_V->code);	3771	s_return (SCHEME_V->code);
3666		3772
…		…
3678	case OP_IF1: /* if */	3784	case OP_IF1: /* if */
3679	if (is_true (SCHEME_V->value))	3785	if (is_true (SCHEME_V->value))
3680	SCHEME_V->code = car (SCHEME_V->code);	3786	SCHEME_V->code = car (SCHEME_V->code);
3681	else	3787	else
3682	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */	3788	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
		3789
3683	s_goto (OP_EVAL);	3790	s_goto (OP_EVAL);
3684		3791
3685	case OP_LET0: /* let */	3792	case OP_LET0: /* let */
3686	SCHEME_V->args = NIL;	3793	SCHEME_V->args = NIL;
3687	SCHEME_V->value = SCHEME_V->code;	3794	SCHEME_V->value = SCHEME_V->code;
…		…
3843	}	3950	}
3844	else	3951	else
3845	{	3952	{
3846	if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)	3953	if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3847	s_return (NIL);	3954	s_return (NIL);
3848	else	3955
3849	{
3850	s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);	3956	s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3851	SCHEME_V->code = caar (SCHEME_V->code);	3957	SCHEME_V->code = caar (SCHEME_V->code);
3852	s_goto (OP_EVAL);	3958	s_goto (OP_EVAL);
3853	}
3854	}	3959	}
3855		3960
3856	case OP_DELAY: /* delay */	3961	case OP_DELAY: /* delay */
3857	x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);	3962	x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3858	set_typeflag (x, T_PROMISE);	3963	set_typeflag (x, T_PROMISE);
…		…
3869	case OP_AND1: /* and */	3974	case OP_AND1: /* and */
3870	if (is_false (SCHEME_V->value))	3975	if (is_false (SCHEME_V->value))
3871	s_return (SCHEME_V->value);	3976	s_return (SCHEME_V->value);
3872	else if (SCHEME_V->code == NIL)	3977	else if (SCHEME_V->code == NIL)
3873	s_return (SCHEME_V->value);	3978	s_return (SCHEME_V->value);
3874	else	3979
3875	{
3876	s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));	3980	s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3877	SCHEME_V->code = car (SCHEME_V->code);	3981	SCHEME_V->code = car (SCHEME_V->code);
3878	s_goto (OP_EVAL);	3982	s_goto (OP_EVAL);
3879	}
3880		3983
3881	case OP_OR0: /* or */	3984	case OP_OR0: /* or */
3882	if (SCHEME_V->code == NIL)	3985	if (SCHEME_V->code == NIL)
3883	s_return (S_F);	3986	s_return (S_F);
3884		3987
…		…
3889	case OP_OR1: /* or */	3992	case OP_OR1: /* or */
3890	if (is_true (SCHEME_V->value))	3993	if (is_true (SCHEME_V->value))
3891	s_return (SCHEME_V->value);	3994	s_return (SCHEME_V->value);
3892	else if (SCHEME_V->code == NIL)	3995	else if (SCHEME_V->code == NIL)
3893	s_return (SCHEME_V->value);	3996	s_return (SCHEME_V->value);
3894	else	3997
3895	{
3896	s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));	3998	s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3897	SCHEME_V->code = car (SCHEME_V->code);	3999	SCHEME_V->code = car (SCHEME_V->code);
3898	s_goto (OP_EVAL);	4000	s_goto (OP_EVAL);
3899	}
3900		4001
3901	case OP_C0STREAM: /* cons-stream */	4002	case OP_C0STREAM: /* cons-stream */
3902	s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));	4003	s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3903	SCHEME_V->code = car (SCHEME_V->code);	4004	SCHEME_V->code = car (SCHEME_V->code);
3904	s_goto (OP_EVAL);	4005	s_goto (OP_EVAL);
…		…
3969	s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));	4070	s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3970	SCHEME_V->code = caar (x);	4071	SCHEME_V->code = caar (x);
3971	s_goto (OP_EVAL);	4072	s_goto (OP_EVAL);
3972	}	4073	}
3973	}	4074	}
3974	else	4075
3975	s_return (NIL);	4076	s_return (NIL);
3976		4077
3977	case OP_CASE2: /* case */	4078	case OP_CASE2: /* case */
3978	if (is_true (SCHEME_V->value))	4079	if (is_true (SCHEME_V->value))
3979	s_goto (OP_BEGIN);	4080	s_goto (OP_BEGIN);
3980	else	4081
3981	s_return (NIL);	4082	s_return (NIL);
3982		4083
3983	case OP_PAPPLY: /* apply */	4084	case OP_PAPPLY: /* apply */
3984	SCHEME_V->code = car (args);	4085	SCHEME_V->code = car (args);
3985	SCHEME_V->args = list_star (SCHEME_A_ cdr (args));	4086	SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3986	/SCHEME_V->args = cadr(args); /	4087	/SCHEME_V->args = cadr(args); /
…		…
4636	else	4737	else
4637	SCHEME_V->print_flag = 0;	4738	SCHEME_V->print_flag = 0;
4638		4739
4639	s_goto (OP_P0LIST);	4740	s_goto (OP_P0LIST);
4640		4741
		4742	//TODO: move to scheme
4641	case OP_NEWLINE: /* newline */	4743	case OP_NEWLINE: /* newline */
4642	if (is_pair (args))	4744	if (is_pair (args))
4643	{	4745	{
4644	if (a != SCHEME_V->outport)	4746	if (a != SCHEME_V->outport)
4645	{	4747	{
…		…
4647	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);	4749	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4648	SCHEME_V->outport = a;	4750	SCHEME_V->outport = a;
4649	}	4751	}
4650	}	4752	}
4651		4753
4652	putstr (SCHEME_A_ "\n");	4754	putcharacter (SCHEME_A_ '\n');
4653	s_return (S_T);	4755	s_return (S_T);
4654	#endif	4756	#endif
4655		4757
4656	case OP_ERR0: /* error */	4758	case OP_ERR0: /* error */
4657	SCHEME_V->retcode = -1;	4759	SCHEME_V->retcode = -1;
…		…
4666	putstr (SCHEME_A_ strvalue (car (args)));	4768	putstr (SCHEME_A_ strvalue (car (args)));
4667	SCHEME_V->args = cdr (args);	4769	SCHEME_V->args = cdr (args);
4668	s_goto (OP_ERR1);	4770	s_goto (OP_ERR1);
4669		4771
4670	case OP_ERR1: /* error */	4772	case OP_ERR1: /* error */
4671	putstr (SCHEME_A_ " ");	4773	putcharacter (SCHEME_A_ ' ');
4672		4774
4673	if (args != NIL)	4775	if (args != NIL)
4674	{	4776	{
4675	s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);	4777	s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4676	SCHEME_V->args = a;	4778	SCHEME_V->args = a;
4677	SCHEME_V->print_flag = 1;	4779	SCHEME_V->print_flag = 1;
4678	s_goto (OP_P0LIST);	4780	s_goto (OP_P0LIST);
4679	}	4781	}
4680	else	4782	else
4681	{	4783	{
4682	putstr (SCHEME_A_ "\n");	4784	putcharacter (SCHEME_A_ '\n');
4683		4785
4684	if (SCHEME_V->interactive_repl)	4786	if (SCHEME_V->interactive_repl)
4685	s_goto (OP_T0LVL);	4787	s_goto (OP_T0LVL);
4686	else	4788	else
4687	return -1;	4789	return -1;
…		…
5175	pointer b = cdr (args);	5277	pointer b = cdr (args);
5176	int ok_abbr = ok_abbrev (b);	5278	int ok_abbr = ok_abbrev (b);
5177	SCHEME_V->args = car (b);	5279	SCHEME_V->args = car (b);
5178		5280
5179	if (a == SCHEME_V->QUOTE && ok_abbr)	5281	if (a == SCHEME_V->QUOTE && ok_abbr)
5180	putstr (SCHEME_A_ "'");	5282	putcharacter (SCHEME_A_ '\'');
5181	else if (a == SCHEME_V->QQUOTE && ok_abbr)	5283	else if (a == SCHEME_V->QQUOTE && ok_abbr)
5182	putstr (SCHEME_A_ "`");	5284	putcharacter (SCHEME_A_ '`');
5183	else if (a == SCHEME_V->UNQUOTE && ok_abbr)	5285	else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5184	putstr (SCHEME_A_ ",");	5286	putcharacter (SCHEME_A_ ',');
5185	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)	5287	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5186	putstr (SCHEME_A_ ",@");	5288	putstr (SCHEME_A_ ",@");
5187	else	5289	else
5188	{	5290	{
5189	putstr (SCHEME_A_ "(");	5291	putcharacter (SCHEME_A_ '(');
5190	s_save (SCHEME_A_ OP_P1LIST, b, NIL);	5292	s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5191	SCHEME_V->args = a;	5293	SCHEME_V->args = a;
5192	}	5294	}
5193		5295
5194	s_goto (OP_P0LIST);	5296	s_goto (OP_P0LIST);
…		…
5196		5298
5197	case OP_P1LIST:	5299	case OP_P1LIST:
5198	if (is_pair (args))	5300	if (is_pair (args))
5199	{	5301	{
5200	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);	5302	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5201	putstr (SCHEME_A_ " ");	5303	putcharacter (SCHEME_A_ ' ');
5202	SCHEME_V->args = car (args);	5304	SCHEME_V->args = car (args);
5203	s_goto (OP_P0LIST);	5305	s_goto (OP_P0LIST);
5204	}	5306	}
5205	else if (is_vector (args))	5307	else if (is_vector (args))
5206	{	5308	{
…		…
5214	{	5316	{
5215	putstr (SCHEME_A_ " . ");	5317	putstr (SCHEME_A_ " . ");
5216	printatom (SCHEME_A_ args, SCHEME_V->print_flag);	5318	printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5217	}	5319	}
5218		5320
5219	putstr (SCHEME_A_ ")");	5321	putcharacter (SCHEME_A_ ')');
5220	s_return (S_T);	5322	s_return (S_T);
5221	}	5323	}
5222		5324
5223	case OP_PVECFROM:	5325	case OP_PVECFROM:
5224	{	5326	{
…		…
5226	pointer vec = car (args);	5328	pointer vec = car (args);
5227	int len = veclength (vec);	5329	int len = veclength (vec);
5228		5330
5229	if (i == len)	5331	if (i == len)
5230	{	5332	{
5231	putstr (SCHEME_A_ ")");	5333	putcharacter (SCHEME_A_ ')');
5232	s_return (S_T);	5334	s_return (S_T);
5233	}	5335	}
5234	else	5336	else
5235	{	5337	{
5236	pointer elem = vector_get (vec, i);	5338	pointer elem = vector_get (vec, i);
…		…
5238	ivalue_unchecked (cdr (args)) = i + 1;	5340	ivalue_unchecked (cdr (args)) = i + 1;
5239	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);	5341	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5240	SCHEME_V->args = elem;	5342	SCHEME_V->args = elem;
5241		5343
5242	if (i > 0)	5344	if (i > 0)
5243	putstr (SCHEME_A_ " ");	5345	putcharacter (SCHEME_A_ ' ');
5244		5346
5245	s_goto (OP_P0LIST);	5347	s_goto (OP_P0LIST);
5246	}	5348	}
5247	}	5349	}
5248	}	5350	}
…		…
5678	#endif	5780	#endif
5679	}	5781	}
5680		5782
5681	SCHEME_V->gc_verbose = 0;	5783	SCHEME_V->gc_verbose = 0;
5682	dump_stack_initialize (SCHEME_A);	5784	dump_stack_initialize (SCHEME_A);
5683	SCHEME_V->code = NIL;	5785	SCHEME_V->code = NIL;
5684	SCHEME_V->args = NIL;	5786	SCHEME_V->args = NIL;
5685	SCHEME_V->envir = NIL;	5787	SCHEME_V->envir = NIL;
		5788	SCHEME_V->value = NIL;
5686	SCHEME_V->tracing = 0;	5789	SCHEME_V->tracing = 0;
5687		5790
5688	/* init NIL */	5791	/* init NIL */
5689	set_typeflag (NIL, T_ATOM \| T_MARK);	5792	set_typeflag (NIL, T_ATOM \| T_MARK);
5690	set_car (NIL, NIL);	5793	set_car (NIL, NIL);
…		…
5813	SCHEME_V->loadport = NIL;	5916	SCHEME_V->loadport = NIL;
5814	SCHEME_V->gc_verbose = 0;	5917	SCHEME_V->gc_verbose = 0;
5815	gc (SCHEME_A_ NIL, NIL);	5918	gc (SCHEME_A_ NIL, NIL);
5816		5919
5817	for (i = 0; i <= SCHEME_V->last_cell_seg; i++)	5920	for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5818	free (SCHEME_V->alloc_seg[i]);	5921	free (SCHEME_V->cell_seg[i]);
5819		5922
5820	#if SHOW_ERROR_LINE	5923	#if SHOW_ERROR_LINE
5821	for (i = 0; i <= SCHEME_V->file_i; i++)	5924	for (i = 0; i <= SCHEME_V->file_i; i++)
5822	{	5925	{
5823	if (SCHEME_V->load_stack[i].kind & port_file)	5926	if (SCHEME_V->load_stack[i].kind & port_file)
…		…
5844	SCHEME_V->envir = SCHEME_V->global_env;	5947	SCHEME_V->envir = SCHEME_V->global_env;
5845	SCHEME_V->file_i = 0;	5948	SCHEME_V->file_i = 0;
5846	SCHEME_V->load_stack[0].unget = -1;	5949	SCHEME_V->load_stack[0].unget = -1;
5847	SCHEME_V->load_stack[0].kind = port_input \| port_file;	5950	SCHEME_V->load_stack[0].kind = port_input \| port_file;
5848	SCHEME_V->load_stack[0].rep.stdio.file = fin;	5951	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);	5952	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5851	#endif
5852	SCHEME_V->retcode = 0;	5953	SCHEME_V->retcode = 0;
5853		5954
5854	#if USE_PORTS
5855	if (fin == STDIN_FILENO)	5955	if (fin == STDIN_FILENO)
5856	SCHEME_V->interactive_repl = 1;	5956	SCHEME_V->interactive_repl = 1;
5857	#endif
5858		5957
5859	#if USE_PORTS	5958	#if USE_PORTS
5860	#if SHOW_ERROR_LINE	5959	#if SHOW_ERROR_LINE
5861	SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;	5960	SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5862		5961
…		…
5866	#endif	5965	#endif
5867		5966
5868	SCHEME_V->inport = SCHEME_V->loadport;	5967	SCHEME_V->inport = SCHEME_V->loadport;
5869	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	5968	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5870	Eval_Cycle (SCHEME_A_ OP_T0LVL);	5969	Eval_Cycle (SCHEME_A_ OP_T0LVL);
		5970
5871	set_typeflag (SCHEME_V->loadport, T_ATOM);	5971	set_typeflag (SCHEME_V->loadport, T_ATOM);
5872		5972
5873	if (SCHEME_V->retcode == 0)	5973	if (SCHEME_V->retcode == 0)
5874	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5974	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5875	}	5975	}
5876		5976
5877	ecb_cold void	5977	ecb_cold void
5878	scheme_load_string (SCHEME_P_ const char *cmd)	5978	scheme_load_string (SCHEME_P_ const char *cmd)
5879	{	5979	{
		5980	#if USE_PORTs
5880	dump_stack_reset (SCHEME_A);	5981	dump_stack_reset (SCHEME_A);
5881	SCHEME_V->envir = SCHEME_V->global_env;	5982	SCHEME_V->envir = SCHEME_V->global_env;
5882	SCHEME_V->file_i = 0;	5983	SCHEME_V->file_i = 0;
5883	SCHEME_V->load_stack[0].kind = port_input \| port_string;	5984	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 */	5985	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);	5986	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;	5987	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);	5988	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5889	#endif
5890	SCHEME_V->retcode = 0;	5989	SCHEME_V->retcode = 0;
5891	SCHEME_V->interactive_repl = 0;	5990	SCHEME_V->interactive_repl = 0;
5892	SCHEME_V->inport = SCHEME_V->loadport;	5991	SCHEME_V->inport = SCHEME_V->loadport;
5893	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	5992	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5894	Eval_Cycle (SCHEME_A_ OP_T0LVL);	5993	Eval_Cycle (SCHEME_A_ OP_T0LVL);
5895	set_typeflag (SCHEME_V->loadport, T_ATOM);	5994	set_typeflag (SCHEME_V->loadport, T_ATOM);
5896		5995
5897	if (SCHEME_V->retcode == 0)	5996	if (SCHEME_V->retcode == 0)
5898	SCHEME_V->retcode = SCHEME_V->nesting != 0;	5997	SCHEME_V->retcode = SCHEME_V->nesting != 0;
		5998	#else
		5999	abort ();
		6000	#endif
5899	}	6001	}
5900		6002
5901	ecb_cold void	6003	ecb_cold void
5902	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)	6004	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5903	{	6005	{
…		…
6047	}	6149	}
6048	#endif	6150	#endif
6049		6151
6050	do	6152	do
6051	{	6153	{
6052	#if USE_PORTS
6053	if (strcmp (file_name, "-") == 0)	6154	if (strcmp (file_name, "-") == 0)
6054	fin = STDIN_FILENO;	6155	fin = STDIN_FILENO;
6055	else if (strcmp (file_name, "-1") == 0 \|\| strcmp (file_name, "-c") == 0)	6156	else if (strcmp (file_name, "-1") == 0 \|\| strcmp (file_name, "-c") == 0)
6056	{	6157	{
6057	pointer args = NIL;	6158	pointer args = NIL;
…		…
6075	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "args"), args);	6176	scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "args"), args);
6076		6177
6077	}	6178	}
6078	else	6179	else
6079	fin = open (file_name, O_RDONLY);	6180	fin = open (file_name, O_RDONLY);
6080	#endif
6081		6181
6082	if (isfile && fin < 0)	6182	if (isfile && fin < 0)
6083	{	6183	{
6084	putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");	6184	putstr (SCHEME_A_ "Could not open file ");
		6185	putstr (SCHEME_A_ file_name);
		6186	putcharacter (SCHEME_A_ '\n');
6085	}	6187	}
6086	else	6188	else
6087	{	6189	{
6088	if (isfile)	6190	if (isfile)
6089	scheme_load_named_file (SCHEME_A_ fin, file_name);	6191	scheme_load_named_file (SCHEME_A_ fin, file_name);
6090	else	6192	else
6091	scheme_load_string (SCHEME_A_ file_name);	6193	scheme_load_string (SCHEME_A_ file_name);
6092		6194
6093	#if USE_PORTS
6094	if (!isfile \|\| fin != STDIN_FILENO)	6195	if (!isfile \|\| fin != STDIN_FILENO)
6095	{	6196	{
6096	if (SCHEME_V->retcode != 0)	6197	if (SCHEME_V->retcode != 0)
6097	{	6198	{
6098	putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");	6199	putstr (SCHEME_A_ "Errors encountered reading ");
		6200	putstr (SCHEME_A_ file_name);
		6201	putcharacter (SCHEME_A_ '\n');
6099	}	6202	}
6100		6203
6101	if (isfile)	6204	if (isfile)
6102	close (fin);	6205	close (fin);
6103	}	6206	}
6104	#endif
6105	}	6207	}
6106		6208
6107	file_name = *argv++;	6209	file_name = *argv++;
6108	}	6210	}
6109	while (file_name != 0);	6211	while (file_name != 0);

Diff Legend

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

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

Diff Legend

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