ViewVC Help

View File | Revision Log | Show Annotations | Download File

/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.70 by root, Mon Dec 7 22:13:31 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	#if 1	23	#define _GNU_SOURCE 1 /* for malloc mremap */
24	#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
25	#include "malloc.c"
26	#endif
27		24
28	#define SCHEME_SOURCE	25	#define SCHEME_SOURCE
29	#include "scheme-private.h"	26	#include "scheme-private.h"
30	#ifndef WIN32	27	#ifndef WIN32
31	# include <unistd.h>	28	# include <unistd.h>
32	#endif	29	#endif
33	#if USE_MATH	30	#if USE_MATH
34	# include <math.h>	31	# include <math.h>
35	#endif	32	#endif
36		33
		34	#define ECB_NO_THREADS 1
37	#include "ecb.h"	35	#include "ecb.h"
38		36
39	#include <sys/types.h>	37	#include <sys/types.h>
40	#include <sys/stat.h>	38	#include <sys/stat.h>
41	#include <fcntl.h>	39	#include <fcntl.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)
163		172
		173	#endif
		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	{
168	const char *p = s;	179	const char *p = s;
…		…
183	# define stricmp(a,b) strcmp (a, b)	194	# define stricmp(a,b) strcmp (a, b)
184	# define strlwr(s) (s)	195	# define strlwr(s) (s)
185	#endif	196	#endif
186		197
187	#ifndef prompt	198	#ifndef prompt
188	# define prompt "ts> "	199	# define prompt "ms> "
189	#endif	200	#endif
190		201
191	#ifndef InitFile	202	#ifndef InitFile
192	# define InitFile "init.scm"	203	# define InitFile "init.scm"
193	#endif	204	#endif
…		…
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	T_SPECIAL, // #t, #f, '(), eof-object
		225
213	T_NUM_SYSTEM_TYPES	226	T_NUM_SYSTEM_TYPES
214	};	227	};
215		228
216	#define T_MASKTYPE 0x000f	229	#define T_MASKTYPE 0x001f
217	#define T_SYNTAX 0x0010	230	#define T_SYNTAX 0x0020
218	#define T_IMMUTABLE 0x0020	231	#define T_IMMUTABLE 0x0040
219	#define T_ATOM 0x0040 /* only for gc */	232	#define T_ATOM 0x0080 /* only for gc */
220	#define T_MARK 0x0080 /* only for gc */	233	//#define T_MARK 0x0080 /* only for gc */
221		234
222	/* num, for generic arithmetic */	235	/* num, for generic arithmetic */
223	struct num	236	struct num
224	{	237	{
225	IVALUE ivalue;	238	IVALUE ivalue;
…		…
316	string_value (pointer p)	329	string_value (pointer p)
317	{	330	{
318	return strvalue (p);	331	return strvalue (p);
319	}	332	}
320		333
321	#define ivalue_unchecked(p) CELL(p)->object.ivalue	334	#define ivalue_unchecked(p) (CELL(p)->object.ivalue + 0)
322	#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)	335	#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
323		336
324	#if USE_REAL	337	#if USE_REAL
325	#define rvalue_unchecked(p) CELL(p)->object.rvalue	338	#define rvalue_unchecked(p) CELL(p)->object.rvalue
326	#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)	339	#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
…		…
371		384
372	static pointer cadar (pointer p) { return car (cdr (car (p))); }	385	static pointer cadar (pointer p) { return car (cdr (car (p))); }
373	static pointer caddr (pointer p) { return car (cdr (cdr (p))); }	386	static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
374	static pointer cdaar (pointer p) { return cdr (car (car (p))); }	387	static pointer cdaar (pointer p) { return cdr (car (car (p))); }
375		388
		389	static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); }
		390
376	INTERFACE void	391	INTERFACE void
377	set_car (pointer p, pointer q)	392	set_car (pointer p, pointer q)
378	{	393	{
379	CELL(p)->object.cons.car = CELL (q);	394	CELL(p)->object.cons.car = CELL (q);
380	}	395	}
…		…
496		511
497	#define is_atom(p) (typeflag (p) & T_ATOM)	512	#define is_atom(p) (typeflag (p) & T_ATOM)
498	#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)	513	#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
499	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)	514	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
500		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
501	#define is_mark(p) (typeflag (p) & T_MARK)	521	#define is_mark(p) (typeflag (p) & T_MARK)
502	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)	522	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
503	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	523	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
		524	#endif
504		525
505	INTERFACE int	526	INTERFACE int
506	is_immutable (pointer p)	527	is_immutable (pointer p)
507	{	528	{
508	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	529	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
…		…
569	{	590	{
570	return list_length (SCHEME_A_ a) >= 0;	591	return list_length (SCHEME_A_ a) >= 0;
571	}	592	}
572		593
573	#if USE_CHAR_CLASSIFIERS	594	#if USE_CHAR_CLASSIFIERS
		595
574	ecb_inline int	596	ecb_inline int
575	Cisalpha (int c)	597	Cisalpha (int c)
576	{	598	{
577	return isascii (c) && isalpha (c);	599	return isascii (c) && isalpha (c);
578	}	600	}
…		…
668	static int file_interactive (SCHEME_P);	690	static int file_interactive (SCHEME_P);
669	ecb_inline int is_one_of (const char *s, int c);	691	ecb_inline int is_one_of (const char *s, int c);
670	static int alloc_cellseg (SCHEME_P);	692	static int alloc_cellseg (SCHEME_P);
671	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);	693	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
672	static void finalize_cell (SCHEME_P_ pointer a);	694	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);	695	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
675	static pointer mk_number (SCHEME_P_ const num n);	696	static pointer mk_number (SCHEME_P_ const num n);
676	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);
677	static pointer mk_vector (SCHEME_P_ uint32_t len);	698	static pointer mk_vector (SCHEME_P_ uint32_t len);
678	static pointer mk_atom (SCHEME_P_ char *q);	699	static pointer mk_atom (SCHEME_P_ char *q);
679	static pointer mk_sharp_const (SCHEME_P_ char *name);	700	static pointer mk_sharp_const (SCHEME_P_ char *name);
680		701
		702	static pointer mk_port (SCHEME_P_ port *p);
		703
681	#if USE_PORTS	704	#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);	705	static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
684	static pointer port_from_file (SCHEME_P_ int, int prop);	706	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);	707	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);	708	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);	709	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);	710	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);	711	static void port_close (SCHEME_P_ pointer p, int flag);
690	#endif	712	#endif
		713
691	static void mark (pointer a);	714	static void mark (pointer a);
692	static void gc (SCHEME_P_ pointer a, pointer b);	715	static void gc (SCHEME_P_ pointer a, pointer b);
693	static int basic_inchar (port *pt);	716	static int basic_inchar (port *pt);
694	static int inchar (SCHEME_P);	717	static int inchar (SCHEME_P);
695	static void backchar (SCHEME_P_ int c);	718	static void backchar (SCHEME_P_ int c);
696	static char *readstr_upto (SCHEME_P_ int skip, const char *delim);	719	static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
697	static pointer readstrexp (SCHEME_P_ char delim);	720	static pointer readstrexp (SCHEME_P_ char delim);
698	ecb_inline int skipspace (SCHEME_P);	721	static int skipspace (SCHEME_P);
699	static int token (SCHEME_P);	722	static int token (SCHEME_P);
700	static void printslashstring (SCHEME_P_ char *s, int len);	723	static void printslashstring (SCHEME_P_ char *s, int len);
701	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);
702	static void printatom (SCHEME_P_ pointer l, int f);	725	static void printatom (SCHEME_P_ pointer l, int f);
703	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	726	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
902		925
903	if (!cp && USE_ERROR_CHECKING)	926	if (!cp && USE_ERROR_CHECKING)
904	return k;	927	return k;
905		928
906	i = ++SCHEME_V->last_cell_seg;	929	i = ++SCHEME_V->last_cell_seg;
907	SCHEME_V->alloc_seg[i] = cp;
908		930
909	newp = (struct cell *)cp;	931	newp = (struct cell *)cp;
910	SCHEME_V->cell_seg[i] = newp;	932	SCHEME_V->cell_seg[i] = newp;
911	SCHEME_V->cell_segsize[i] = segsize;	933	SCHEME_V->cell_segsize[i] = segsize;
912	SCHEME_V->fcells += segsize;	934	SCHEME_V->fcells += segsize;
913	last = newp + segsize - 1;	935	last = newp + segsize - 1;
914		936
915	for (p = newp; p <= last; p++)	937	for (p = newp; p <= last; p++)
916	{	938	{
917	pointer cp = POINTER (p);	939	pointer cp = POINTER (p);
		940	clrmark (cp);
918	set_typeflag (cp, T_PAIR);	941	set_typeflag (cp, T_PAIR);
919	set_car (cp, NIL);	942	set_car (cp, NIL);
920	set_cdr (cp, POINTER (p + 1));	943	set_cdr (cp, POINTER (p + 1));
921	}	944	}
922		945
…		…
935	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	958	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
936	return S_SINK;	959	return S_SINK;
937		960
938	if (SCHEME_V->free_cell == NIL)	961	if (SCHEME_V->free_cell == NIL)
939	{	962	{
940	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;
941		964
942	gc (SCHEME_A_ a, b);	965	gc (SCHEME_A_ a, b);
943		966
944	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)
945	{	968	{
…		…
1043	#endif	1066	#endif
1044		1067
1045	/* Medium level cell allocation */	1068	/* Medium level cell allocation */
1046		1069
1047	/* get new cons cell */	1070	/* get new cons cell */
1048	ecb_hot pointer	1071	ecb_hot static pointer
1049	xcons (SCHEME_P_ pointer a, pointer b, int immutable)	1072	xcons (SCHEME_P_ pointer a, pointer b)
1050	{	1073	{
1051	pointer x = get_cell (SCHEME_A_ a, b);	1074	pointer x = get_cell (SCHEME_A_ a, b);
1052		1075
1053	set_typeflag (x, T_PAIR);	1076	set_typeflag (x, T_PAIR);
1054
1055	if (immutable)
1056	setimmutable (x);
1057		1077
1058	set_car (x, a);	1078	set_car (x, a);
1059	set_cdr (x, b);	1079	set_cdr (x, b);
1060		1080
1061	return x;	1081	return x;
1062	}	1082	}
		1083
		1084	ecb_hot static pointer
		1085	ximmutable_cons (SCHEME_P_ pointer a, pointer b)
		1086	{
		1087	pointer x = xcons (SCHEME_A_ a, b);
		1088	setimmutable (x);
		1089	return x;
		1090	}
		1091
		1092	#define cons(a,b) xcons (SCHEME_A_ a, b)
		1093	#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1063		1094
1064	ecb_cold static pointer	1095	ecb_cold static pointer
1065	generate_symbol (SCHEME_P_ const char *name)	1096	generate_symbol (SCHEME_P_ const char *name)
1066	{	1097	{
1067	pointer x = mk_string (SCHEME_A_ name);	1098	pointer x = mk_string (SCHEME_A_ name);
…		…
1075	#ifndef USE_OBJECT_LIST	1106	#ifndef USE_OBJECT_LIST
1076		1107
1077	static int	1108	static int
1078	hash_fn (const char *key, int table_size)	1109	hash_fn (const char *key, int table_size)
1079	{	1110	{
1080	const unsigned char *p = key;	1111	const unsigned char *p = (unsigned char *)key;
1081	uint32_t hash = 2166136261;	1112	uint32_t hash = 2166136261U;
1082		1113
1083	while (*p)	1114	while (*p)
1084	hash = (hash ^ *p++) * 16777619;	1115	hash = (hash ^ *p++) * 16777619;
1085		1116
1086	return hash % table_size;	1117	return hash % table_size;
…		…
1178	return SCHEME_V->oblist;	1209	return SCHEME_V->oblist;
1179	}	1210	}
1180		1211
1181	#endif	1212	#endif
1182		1213
1183	#if USE_PORTS
1184	ecb_cold static pointer	1214	ecb_cold static pointer
1185	mk_port (SCHEME_P_ port *p)	1215	mk_port (SCHEME_P_ port *p)
1186	{	1216	{
1187	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1217	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1188		1218
1189	set_typeflag (x, T_PORT | T_ATOM);	1219	set_typeflag (x, T_PORT | T_ATOM);
1190	set_port (x, p);	1220	set_port (x, p);
1191		1221
1192	return x;	1222	return x;
1193	}	1223	}
1194	#endif
1195		1224
1196	ecb_cold pointer	1225	ecb_cold pointer
1197	mk_foreign_func (SCHEME_P_ foreign_func f)	1226	mk_foreign_func (SCHEME_P_ foreign_func f)
1198	{	1227	{
1199	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1228	pointer x = get_cell (SCHEME_A_ NIL, NIL);
…		…
1230	if (!*pp)	1259	if (!*pp)
1231	{	1260	{
1232	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1261	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1233		1262
1234	set_typeflag (x, T_INTEGER | T_ATOM);	1263	set_typeflag (x, T_INTEGER | T_ATOM);
1235	setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */	1264	setimmutable (x); /* shouldn't do anything, doesn't cost anything */
1236	set_ivalue (x, n);	1265	set_ivalue (x, n);
1237		1266
1238	*pp = x;	1267	*pp = x;
1239	}	1268	}
1240		1269
…		…
1517	return mk_character (SCHEME_A_ c);	1546	return mk_character (SCHEME_A_ c);
1518	}	1547	}
1519	else	1548	else
1520	{	1549	{
1521	/* identify base by string index */	1550	/* identify base by string index */
1522	const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";	1551	const char baseidx[18] = "ffbf" "ffff" "ofdf" "ffff" "x";
1523	char *base = strchr (baseidx, *name);	1552	char *base = strchr (baseidx, *name);
1524		1553
1525	if (base)	1554	if (base && *base)
1526	return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));	1555	return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1527		1556
1528	return NIL;	1557	return NIL;
1529	}	1558	}
1530	}	1559	}
…		…
1722	/* ========== Routines for Reading ========== */	1751	/* ========== Routines for Reading ========== */
1723		1752
1724	ecb_cold static int	1753	ecb_cold static int
1725	file_push (SCHEME_P_ const char *fname)	1754	file_push (SCHEME_P_ const char *fname)
1726	{	1755	{
1727	#if USE_PORTS
1728	int fin;	1756	int fin;
1729		1757
1730	if (SCHEME_V->file_i == MAXFIL - 1)	1758	if (SCHEME_V->file_i == MAXFIL - 1)
1731	return 0;	1759	return 0;
1732		1760
…		…
1749	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);
1750	#endif	1778	#endif
1751	}	1779	}
1752		1780
1753	return fin >= 0;	1781	return fin >= 0;
1754
1755	#else
1756	return 1;
1757	#endif
1758	}	1782	}
1759		1783
1760	ecb_cold static void	1784	ecb_cold static void
1761	file_pop (SCHEME_P)	1785	file_pop (SCHEME_P)
1762	{	1786	{
…		…
1946	}	1970	}
1947	}	1971	}
1948	#endif	1972	#endif
1949		1973
1950	/* get new character from input file */	1974	/* get new character from input file */
1951	static int	1975	ecb_cold static int
1952	inchar (SCHEME_P)	1976	inchar (SCHEME_P)
1953	{	1977	{
1954	int c;	1978	int c;
1955	port *pt = port (SCHEME_V->inport);	1979	port *pt = port (SCHEME_V->inport);
1956		1980
…		…
1970	}	1994	}
1971		1995
1972	return c;	1996	return c;
1973	}	1997	}
1974		1998
1975	static int ungot = -1;	1999	ecb_cold static int
1976
1977	static int
1978	basic_inchar (port *pt)	2000	basic_inchar (port *pt)
1979	{	2001	{
1980	#if USE_PORTS
1981	if (pt->unget != -1)	2002	if (pt->unget != -1)
1982	{	2003	{
1983	int r = pt->unget;	2004	int r = pt->unget;
1984	pt->unget = -1;	2005	pt->unget = -1;
1985	return r;	2006	return r;
1986	}	2007	}
1987		2008
		2009	#if USE_PORTS
1988	if (pt->kind & port_file)	2010	if (pt->kind & port_file)
1989	{	2011	{
1990	char c;	2012	char c;
1991		2013
1992	if (!read (pt->rep.stdio.file, &c, 1))	2014	if (!read (pt->rep.stdio.file, &c, 1))
…		…
2000	return EOF;	2022	return EOF;
2001	else	2023	else
2002	return *pt->rep.string.curr++;	2024	return *pt->rep.string.curr++;
2003	}	2025	}
2004	#else	2026	#else
2005	if (ungot == -1)
2006	{
2007	char c;	2027	char c;
2008	if (!read (0, &c, 1))	2028
		2029	if (!read (pt->rep.stdio.file, &c, 1))
2009	return EOF;	2030	return EOF;
2010		2031
2011	ungot = c;
2012	}
2013
2014	{
2015	int r = ungot;
2016	ungot = -1;
2017	return r;	2032	return c;
2018	}
2019	#endif	2033	#endif
2020	}	2034	}
2021		2035
2022	/* back character to input buffer */	2036	/* back character to input buffer */
2023	static void	2037	ecb_cold static void
2024	backchar (SCHEME_P_ int c)	2038	backchar (SCHEME_P_ int c)
2025	{	2039	{
2026	#if USE_PORTS	2040	port *pt = port (SCHEME_V->inport);
2027	port *pt;
2028		2041
2029	if (c == EOF)	2042	if (c == EOF)
2030	return;	2043	return;
2031		2044
2032	pt = port (SCHEME_V->inport);
2033	pt->unget = c;	2045	pt->unget = c;
2034	#else
2035	if (c == EOF)
2036	return;
2037
2038	ungot = c;
2039	#endif
2040	}	2046	}
2041		2047
2042	#if USE_PORTS	2048	#if USE_PORTS
2043	ecb_cold static int	2049	ecb_cold static int
2044	realloc_port_string (SCHEME_P_ port *p)	2050	realloc_port_string (SCHEME_P_ port *p)
…		…
2061	else	2067	else
2062	return 0;	2068	return 0;
2063	}	2069	}
2064	#endif	2070	#endif
2065		2071
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	2072	ecb_cold static void
2087	putchars (SCHEME_P_ const char *s, int len)	2073	putchars (SCHEME_P_ const char *s, int len)
2088	{	2074	{
		2075	port *pt = port (SCHEME_V->outport);
		2076
2089	#if USE_PORTS	2077	#if USE_PORTS
2090	port *pt = port (SCHEME_V->outport);
2091
2092	if (pt->kind & port_file)	2078	if (pt->kind & port_file)
2093	write (pt->rep.stdio.file, s, len);	2079	write (pt->rep.stdio.file, s, len);
2094	else	2080	else
2095	{	2081	{
2096	for (; len; len--)	2082	for (; len; len--)
…		…
2101	*pt->rep.string.curr++ = *s++;	2087	*pt->rep.string.curr++ = *s++;
2102	}	2088	}
2103	}	2089	}
2104		2090
2105	#else	2091	#else
2106	write (1, s, len);	2092	write (1, s, len); // output not initialised
2107	#endif	2093	#endif
2108	}	2094	}
2109		2095
2110	ecb_cold INTERFACE void	2096	INTERFACE void
		2097	putstr (SCHEME_P_ const char *s)
		2098	{
		2099	putchars (SCHEME_A_ s, strlen (s));
		2100	}
		2101
		2102	INTERFACE void
2111	putcharacter (SCHEME_P_ int c)	2103	putcharacter (SCHEME_P_ int c)
2112	{	2104	{
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;	2105	char cc = c;
2131	write (1, &c, 1);	2106
2132	#endif	2107	putchars (SCHEME_A_ &cc, 1);
2133	}	2108	}
2134		2109
2135	/* read characters up to delimiter, but cater to character constants */	2110	/* read characters up to delimiter, but cater to character constants */
2136	ecb_cold static char *	2111	ecb_cold static char *
2137	readstr_upto (SCHEME_P_ int skip, const char *delim)	2112	readstr_upto (SCHEME_P_ int skip, const char *delim)
…		…
2198	case 'a': *p++ = '\a'; state = st_ok; break;	2173	case 'a': *p++ = '\a'; state = st_ok; break;
2199	case 'n': *p++ = '\n'; state = st_ok; break;	2174	case 'n': *p++ = '\n'; state = st_ok; break;
2200	case 'r': *p++ = '\r'; state = st_ok; break;	2175	case 'r': *p++ = '\r'; state = st_ok; break;
2201	case 't': *p++ = '\t'; state = st_ok; break;	2176	case 't': *p++ = '\t'; state = st_ok; break;
2202		2177
2203	//TODO: \whitespace eol whitespace	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;
2204		2186
2205	//TODO: x should end in ;, not two-digit hex	2187	//TODO: x should end in ;, not two-digit hex
2206	case 'x':	2188	case 'x':
2207	case 'X':	2189	case 'X':
2208	state = st_x1;	2190	state = st_x1;
…		…
2631	}	2613	}
2632	else if (is_symbol (l))	2614	else if (is_symbol (l))
2633	p = symname (l);	2615	p = symname (l);
2634	else if (is_proc (l))	2616	else if (is_proc (l))
2635	{	2617	{
		2618	p = (char *)procname (l); // ok with r7rs display, but not r7rs write
		2619	#if 0
2636	#if USE_PRINTF	2620	#if USE_PRINTF
2637	p = SCHEME_V->strbuff;	2621	p = SCHEME_V->strbuff;
2638	snprintf (p, STRBUFFSIZE, "#<%s PROCEDURE %ld>", procname (l), procnum (l));	2622	snprintf (p, STRBUFFSIZE, " PROCEDURE %ld>", procname (l), procnum (l));
2639	#else	2623	#else
2640	p = "#<PROCEDURE>";	2624	p = "#<PROCEDURE>";
		2625	#endif
2641	#endif	2626	#endif
2642	}	2627	}
2643	else if (is_macro (l))	2628	else if (is_macro (l))
2644	p = "#<MACRO>";	2629	p = "#<MACRO>";
2645	else if (is_closure (l))	2630	else if (is_closure (l))
…		…
2835	{	2820	{
2836	pointer new_frame;	2821	pointer new_frame;
2837		2822
2838	/* The interaction-environment has about 300 variables in it. */	2823	/* The interaction-environment has about 300 variables in it. */
2839	if (old_env == NIL)	2824	if (old_env == NIL)
2840	new_frame = mk_vector (SCHEME_A_ 461);	2825	new_frame = mk_vector (SCHEME_A_ 29); // was 461
2841	else	2826	else
2842	new_frame = NIL;	2827	new_frame = NIL;
2843		2828
2844	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2829	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2845	setenvironment (SCHEME_V->envir);	2830	setenvironment (SCHEME_V->envir);
…		…
2964	/* ========== Evaluation Cycle ========== */	2949	/* ========== Evaluation Cycle ========== */
2965		2950
2966	ecb_cold static int	2951	ecb_cold static int
2967	xError_1 (SCHEME_P_ const char *s, pointer a)	2952	xError_1 (SCHEME_P_ const char *s, pointer a)
2968	{	2953	{
2969	#if USE_ERROR_HOOK
2970	pointer x;
2971	pointer hdl = SCHEME_V->ERROR_HOOK;
2972	#endif
2973
2974	#if USE_PRINTF	2954	#if USE_PRINTF
2975	#if SHOW_ERROR_LINE	2955	#if SHOW_ERROR_LINE
2976	char sbuf[STRBUFFSIZE];	2956	char sbuf[STRBUFFSIZE];
2977		2957
2978	/* make sure error is not in REPL */	2958	/* make sure error is not in REPL */
…		…
2993	}	2973	}
2994	#endif	2974	#endif
2995	#endif	2975	#endif
2996		2976
2997	#if USE_ERROR_HOOK	2977	#if USE_ERROR_HOOK
2998	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);
2999		2979
3000	if (x != NIL)	2980	if (x != NIL)
3001	{	2981	{
3002	pointer code = a	2982	pointer code = a
3003	? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)	2983	? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
…		…
3246	#endif	3226	#endif
3247		3227
3248	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3228	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3249		3229
3250	#if EXPERIMENT	3230	#if EXPERIMENT
		3231
3251	static int	3232	static int
3252	debug (SCHEME_P_ int indent, pointer x)	3233	dtree (SCHEME_P_ int indent, pointer x)
3253	{	3234	{
3254	int c;	3235	int c;
3255		3236
3256	if (is_syntax (x))	3237	if (is_syntax (x))
3257	{	3238	{
…		…
3275	printf ("%*sS<%s>\n", indent, "", symname (x));	3256	printf ("%*sS<%s>\n", indent, "", symname (x));
3276	return 24+8;	3257	return 24+8;
3277		3258
3278	case T_CLOSURE:	3259	case T_CLOSURE:
3279	printf ("%*sS<%s>\n", indent, "", "closure");	3260	printf ("%*sS<%s>\n", indent, "", "closure");
3280	debug (SCHEME_A_ indent + 3, cdr(x));	3261	dtree (SCHEME_A_ indent + 3, cdr(x));
3281	return 32 + debug (SCHEME_A_ indent + 3, car (x));	3262	return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3282		3263
3283	case T_PAIR:	3264	case T_PAIR:
3284	printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));	3265	printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3285	c = debug (SCHEME_A_ indent + 3, car (x));	3266	c = dtree (SCHEME_A_ indent + 3, car (x));
3286	c += debug (SCHEME_A_ indent + 3, cdr (x));	3267	c += dtree (SCHEME_A_ indent + 3, cdr (x));
3287	return c + 1;	3268	return c + 1;
3288		3269
3289	case T_PORT:	3270	case T_PORT:
3290	printf ("%*sS<%s>\n", indent, "", "port");	3271	printf ("%*sS<%s>\n", indent, "", "port");
3291	return 24+8;	3272	return 24+8;
…		…
3294	printf ("%*sS<%s>\n", indent, "", "vector");	3275	printf ("%*sS<%s>\n", indent, "", "vector");
3295	return 24+8;	3276	return 24+8;
3296		3277
3297	case T_ENVIRONMENT:	3278	case T_ENVIRONMENT:
3298	printf ("%*sS<%s>\n", indent, "", "environment");	3279	printf ("%*sS<%s>\n", indent, "", "environment");
3299	return 0 + debug (SCHEME_A_ indent + 3, car (x));	3280	return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3300		3281
3301	default:	3282	default:
3302	printf ("unhandled type %d\n", type (x));	3283	printf ("unhandled type %d\n", type (x));
3303	break;	3284	break;
3304	}	3285	}
3305	}	3286	}
		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
		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
3306	#endif	3714	#endif
3307		3715
3308	/* syntax, eval, core, ... */	3716	/* syntax, eval, core, ... */
3309	ecb_hot static int	3717	ecb_hot static int
3310	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3718	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
…		…
3314		3722
3315	switch (op)	3723	switch (op)
3316	{	3724	{
3317	#if EXPERIMENT //D	3725	#if EXPERIMENT //D
3318	case OP_DEBUG:	3726	case OP_DEBUG:
3319	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);
3320	printf ("\n");	3730	printf ("\n");
3321	s_return (S_T);	3731	s_return (S_T);
		3732	}
		3733
		3734	case OP_DEBUG2:
		3735	return -1;
3322	#endif	3736	#endif
		3737
3323	case OP_LOAD: /* load */	3738	case OP_LOAD: /* load */
3324	if (file_interactive (SCHEME_A))	3739	if (file_interactive (SCHEME_A))
3325	{	3740	{
3326	putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");	3741	putstr (SCHEME_A_ "Loading ");
3327	//D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));	3742	putstr (SCHEME_A_ strvalue (car (args)));
		3743	putcharacter (SCHEME_A_ '\n');
3328	}	3744	}
3329		3745
3330	if (!file_push (SCHEME_A_ strvalue (car (args))))	3746	if (!file_push (SCHEME_A_ strvalue (car (args))))
3331	Error_1 ("unable to open", car (args));	3747	Error_1 ("unable to open", car (args));
3332	else	3748
3333	{
3334	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	3749	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3335	s_goto (OP_T0LVL);	3750	s_goto (OP_T0LVL);
3336	}
3337		3751
3338	case OP_T0LVL: /* top level */	3752	case OP_T0LVL: /* top level */
3339		3753
3340	/* If we reached the end of file, this loop is done. */	3754	/* If we reached the end of file, this loop is done. */
3341	if (port (SCHEME_V->loadport)->kind & port_saw_EOF)	3755	if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
…		…
3357	/* If interactive, be nice to user. */	3771	/* If interactive, be nice to user. */
3358	if (file_interactive (SCHEME_A))	3772	if (file_interactive (SCHEME_A))
3359	{	3773	{
3360	SCHEME_V->envir = SCHEME_V->global_env;	3774	SCHEME_V->envir = SCHEME_V->global_env;
3361	dump_stack_reset (SCHEME_A);	3775	dump_stack_reset (SCHEME_A);
3362	putstr (SCHEME_A_ "\n");	3776	putcharacter (SCHEME_A_ '\n');
		3777	#if EXPERIMENT
		3778	system ("ps v $PPID");
		3779	#endif
3363	putstr (SCHEME_A_ prompt);	3780	putstr (SCHEME_A_ prompt);
3364	}	3781	}
3365		3782
3366	/* Set up another iteration of REPL */	3783	/* Set up another iteration of REPL */
3367	SCHEME_V->nesting = 0;	3784	SCHEME_V->nesting = 0;
…		…
3402	{	3819	{
3403	SCHEME_V->print_flag = 1;	3820	SCHEME_V->print_flag = 1;
3404	SCHEME_V->args = SCHEME_V->value;	3821	SCHEME_V->args = SCHEME_V->value;
3405	s_goto (OP_P0LIST);	3822	s_goto (OP_P0LIST);
3406	}	3823	}
3407	else	3824
3408	s_return (SCHEME_V->value);	3825	s_return (SCHEME_V->value);
3409		3826
3410	case OP_EVAL: /* main part of evaluation */	3827	case OP_EVAL: /* main part of evaluation */
3411	#if USE_TRACING	3828	#if USE_TRACING
3412	if (SCHEME_V->tracing)	3829	if (SCHEME_V->tracing)
3413	{	3830	{
…		…
3446	/* 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)); */
3447	SCHEME_V->code = x;	3864	SCHEME_V->code = x;
3448	s_goto (OP_EVAL);	3865	s_goto (OP_EVAL);
3449	}	3866	}
3450	}	3867	}
3451	else	3868
3452	s_return (SCHEME_V->code);	3869	s_return (SCHEME_V->code);
3453		3870
3454	case OP_E0ARGS: /* eval arguments */	3871	case OP_E0ARGS: /* eval arguments */
3455	if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */	3872	if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3456	{	3873	{
3457	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);	3874	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3458	SCHEME_V->args = cons (SCHEME_V->code, NIL);	3875	SCHEME_V->args = cons (SCHEME_V->code, NIL);
3459	SCHEME_V->code = SCHEME_V->value;	3876	SCHEME_V->code = SCHEME_V->value;
3460	s_goto (OP_APPLY);	3877	s_goto (OP_APPLY);
3461	}	3878	}
3462	else	3879
3463	{
3464	SCHEME_V->code = cdr (SCHEME_V->code);	3880	SCHEME_V->code = cdr (SCHEME_V->code);
3465	s_goto (OP_E1ARGS);	3881	s_goto (OP_E1ARGS);
3466	}
3467		3882
3468	case OP_E1ARGS: /* eval arguments */	3883	case OP_E1ARGS: /* eval arguments */
3469	args = cons (SCHEME_V->value, args);	3884	args = cons (SCHEME_V->value, args);
3470		3885
3471	if (is_pair (SCHEME_V->code)) /* continue */	3886	if (is_pair (SCHEME_V->code)) /* continue */
…		…
3482	SCHEME_V->args = cdr (args);	3897	SCHEME_V->args = cdr (args);
3483	s_goto (OP_APPLY);	3898	s_goto (OP_APPLY);
3484	}	3899	}
3485		3900
3486	#if USE_TRACING	3901	#if USE_TRACING
3487
3488	case OP_TRACING:	3902	case OP_TRACING:
3489	{	3903	{
3490	int tr = SCHEME_V->tracing;	3904	int tr = SCHEME_V->tracing;
3491		3905
3492	SCHEME_V->tracing = ivalue_unchecked (car (args));	3906	SCHEME_V->tracing = ivalue_unchecked (car (args));
3493	s_return (mk_integer (SCHEME_A_ tr));	3907	s_return (mk_integer (SCHEME_A_ tr));
3494	}	3908	}
3495
3496	#endif	3909	#endif
3497		3910
3498	case OP_APPLY: /* apply 'code' to 'args' */	3911	case OP_APPLY: /* apply 'code' to 'args' */
3499	#if USE_TRACING	3912	#if USE_TRACING
3500	if (SCHEME_V->tracing)	3913	if (SCHEME_V->tracing)
…		…
3510		3923
3511	case OP_REAL_APPLY:	3924	case OP_REAL_APPLY:
3512	#endif	3925	#endif
3513	if (is_proc (SCHEME_V->code))	3926	if (is_proc (SCHEME_V->code))
3514	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */	3927	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3515	else if (is_foreign (SCHEME_V->code))
3516	{
3517	/* Keep nested calls from GC'ing the arglist */
3518	push_recent_alloc (SCHEME_A_ args, NIL);
3519	x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3520
3521	s_return (x);
3522	}
3523	else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */	3928	else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3524	{	3929	{
3525	/* Should not accept promise */	3930	/* Should not accept promise */
3526	/* make environment */	3931	/* make environment */
3527	new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));	3932	new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));
…		…
3554	else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */	3959	else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3555	{	3960	{
3556	ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));	3961	ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3557	s_return (args != NIL ? car (args) : NIL);	3962	s_return (args != NIL ? car (args) : NIL);
3558	}	3963	}
3559	else	3964	else if (is_foreign (SCHEME_V->code))
		3965	{
		3966	/* Keep nested calls from GC'ing the arglist */
		3967	push_recent_alloc (SCHEME_A_ args, NIL);
		3968	x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
		3969
		3970	s_return (x);
		3971	}
		3972
3560	Error_0 ("illegal function");	3973	Error_0 ("illegal function");
3561		3974
3562	case OP_DOMACRO: /* do macro */	3975	case OP_DOMACRO: /* do macro */
3563	SCHEME_V->code = SCHEME_V->value;	3976	SCHEME_V->code = SCHEME_V->value;
3564	s_goto (OP_EVAL);	3977	s_goto (OP_EVAL);
3565		3978
…		…
3629	else	4042	else
3630	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);
3631		4044
3632	s_return (SCHEME_V->code);	4045	s_return (SCHEME_V->code);
3633		4046
3634
3635	case OP_DEFP: /* defined? */	4047	case OP_DEFP: /* defined? */
3636	x = SCHEME_V->envir;	4048	x = SCHEME_V->envir;
3637		4049
3638	if (cdr (args) != NIL)	4050	if (cdr (args) != NIL)
3639	x = cadr (args);	4051	x = cadr (args);
…		…
3657	s_return (SCHEME_V->value);	4069	s_return (SCHEME_V->value);
3658	}	4070	}
3659	else	4071	else
3660	Error_1 ("set!: unbound variable:", SCHEME_V->code);	4072	Error_1 ("set!: unbound variable:", SCHEME_V->code);
3661		4073
3662
3663	case OP_BEGIN: /* begin */	4074	case OP_BEGIN: /* begin */
3664	if (!is_pair (SCHEME_V->code))	4075	if (!is_pair (SCHEME_V->code))
3665	s_return (SCHEME_V->code);	4076	s_return (SCHEME_V->code);
3666		4077
3667	if (cdr (SCHEME_V->code) != NIL)	4078	if (cdr (SCHEME_V->code) != NIL)
…		…
3678	case OP_IF1: /* if */	4089	case OP_IF1: /* if */
3679	if (is_true (SCHEME_V->value))	4090	if (is_true (SCHEME_V->value))
3680	SCHEME_V->code = car (SCHEME_V->code);	4091	SCHEME_V->code = car (SCHEME_V->code);
3681	else	4092	else
3682	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
3683	s_goto (OP_EVAL);	4095	s_goto (OP_EVAL);
3684		4096
3685	case OP_LET0: /* let */	4097	case OP_LET0: /* let */
3686	SCHEME_V->args = NIL;	4098	SCHEME_V->args = NIL;
3687	SCHEME_V->value = SCHEME_V->code;	4099	SCHEME_V->value = SCHEME_V->code;
3688	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);
3689	s_goto (OP_LET1);	4101	s_goto (OP_LET1);
3690		4102
3691	case OP_LET1: /* let (calculate parameters) */	4103	case OP_LET1: /* let (calculate parameters) */
		4104	case OP_LET1REC: /* letrec (calculate parameters) */
3692	args = cons (SCHEME_V->value, args);	4105	args = cons (SCHEME_V->value, args);
3693		4106
3694	if (is_pair (SCHEME_V->code)) /* continue */	4107	if (is_pair (SCHEME_V->code)) /* continue */
3695	{	4108	{
3696	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)))
3697	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));
3698		4111
3699	s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code));	4112	s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code));
3700	SCHEME_V->code = cadar (SCHEME_V->code);	4113	SCHEME_V->code = cadar (SCHEME_V->code);
3701	SCHEME_V->args = NIL;	4114	SCHEME_V->args = NIL;
3702	s_goto (OP_EVAL);	4115	s_goto (OP_EVAL);
3703	}	4116	}
3704	else /* end */	4117
3705	{	4118	/* end */
3706	args = reverse_in_place (SCHEME_A_ NIL, args);	4119	args = reverse_in_place (SCHEME_A_ NIL, args);
3707	SCHEME_V->code = car (args);	4120	SCHEME_V->code = car (args);
3708	SCHEME_V->args = cdr (args);	4121	SCHEME_V->args = cdr (args);
3709	s_goto (OP_LET2);	4122	s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC);
3710	}
3711		4123
3712	case OP_LET2: /* let */	4124	case OP_LET2: /* let */
3713	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);	4125	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3714		4126
3715	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;
…		…
3719	if (is_symbol (car (SCHEME_V->code))) /* named let */	4131	if (is_symbol (car (SCHEME_V->code))) /* named let */
3720	{	4132	{
3721	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))
3722	{	4134	{
3723	if (!is_pair (x))	4135	if (!is_pair (x))
3724	Error_1 ("Bad syntax of binding in let :", x);	4136	Error_1 ("Bad syntax of binding in let:", x);
3725		4137
3726	if (!is_list (SCHEME_A_ car (x)))	4138	if (!is_list (SCHEME_A_ car (x)))
3727	Error_1 ("Bad syntax of binding in let :", car (x));	4139	Error_1 ("Bad syntax of binding in let:", car (x));
3728		4140
3729	args = cons (caar (x), args);	4141	args = cons (caar (x), args);
3730	}	4142	}
3731		4143
3732	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)),
…		…
3749	SCHEME_V->code = cdr (SCHEME_V->code);	4161	SCHEME_V->code = cdr (SCHEME_V->code);
3750	s_goto (OP_BEGIN);	4162	s_goto (OP_BEGIN);
3751	}	4163	}
3752		4164
3753	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)))
3754	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));
3755		4167
3756	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));
3757	SCHEME_V->code = car (cdaar (SCHEME_V->code));	4169	SCHEME_V->code = car (cdaar (SCHEME_V->code));
3758	s_goto (OP_EVAL);	4170	s_goto (OP_EVAL);
3759		4171
…		…
3770	s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);	4182	s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3771	SCHEME_V->code = cadar (SCHEME_V->code);	4183	SCHEME_V->code = cadar (SCHEME_V->code);
3772	SCHEME_V->args = NIL;	4184	SCHEME_V->args = NIL;
3773	s_goto (OP_EVAL);	4185	s_goto (OP_EVAL);
3774	}	4186	}
3775	else /* end */	4187
		4188	/* end */
3776	{	4189
3777	SCHEME_V->code = args;	4190	SCHEME_V->code = args;
3778	SCHEME_V->args = NIL;	4191	SCHEME_V->args = NIL;
3779	s_goto (OP_BEGIN);	4192	s_goto (OP_BEGIN);
3780	}
3781		4193
3782	case OP_LET0REC: /* letrec */	4194	case OP_LET0REC: /* letrec */
3783	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);	4195	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3784	SCHEME_V->args = NIL;	4196	SCHEME_V->args = NIL;
3785	SCHEME_V->value = SCHEME_V->code;	4197	SCHEME_V->value = SCHEME_V->code;
3786	SCHEME_V->code = car (SCHEME_V->code);	4198	SCHEME_V->code = car (SCHEME_V->code);
3787	s_goto (OP_LET1REC);	4199	s_goto (OP_LET1REC);
3788		4200
3789	case OP_LET1REC: /* letrec (calculate parameters) */	4201	/* OP_LET1REC handled by OP_LET1 */
3790	args = cons (SCHEME_V->value, args);
3791
3792	if (is_pair (SCHEME_V->code)) /* continue */
3793	{
3794	if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3795	Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3796
3797	s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3798	SCHEME_V->code = cadar (SCHEME_V->code);
3799	SCHEME_V->args = NIL;
3800	s_goto (OP_EVAL);
3801	}
3802	else /* end */
3803	{
3804	args = reverse_in_place (SCHEME_A_ NIL, args);
3805	SCHEME_V->code = car (args);
3806	SCHEME_V->args = cdr (args);
3807	s_goto (OP_LET2REC);
3808	}
3809		4202
3810	case OP_LET2REC: /* letrec */	4203	case OP_LET2REC: /* letrec */
3811	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))
3812	new_slot_in_env (SCHEME_A_ caar (x), car (y));	4205	new_slot_in_env (SCHEME_A_ caar (x), car (y));
3813		4206
…		…
3843	}	4236	}
3844	else	4237	else
3845	{	4238	{
3846	if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)	4239	if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3847	s_return (NIL);	4240	s_return (NIL);
3848	else	4241
3849	{
3850	s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);	4242	s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3851	SCHEME_V->code = caar (SCHEME_V->code);	4243	SCHEME_V->code = caar (SCHEME_V->code);
3852	s_goto (OP_EVAL);	4244	s_goto (OP_EVAL);
3853	}
3854	}	4245	}
3855		4246
3856	case OP_DELAY: /* delay */	4247	case OP_DELAY: /* delay */
3857	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);
3858	set_typeflag (x, T_PROMISE);	4249	set_typeflag (x, T_PROMISE);
…		…
3869	case OP_AND1: /* and */	4260	case OP_AND1: /* and */
3870	if (is_false (SCHEME_V->value))	4261	if (is_false (SCHEME_V->value))
3871	s_return (SCHEME_V->value);	4262	s_return (SCHEME_V->value);
3872	else if (SCHEME_V->code == NIL)	4263	else if (SCHEME_V->code == NIL)
3873	s_return (SCHEME_V->value);	4264	s_return (SCHEME_V->value);
3874	else	4265
3875	{
3876	s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));	4266	s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3877	SCHEME_V->code = car (SCHEME_V->code);	4267	SCHEME_V->code = car (SCHEME_V->code);
3878	s_goto (OP_EVAL);	4268	s_goto (OP_EVAL);
3879	}
3880		4269
3881	case OP_OR0: /* or */	4270	case OP_OR0: /* or */
3882	if (SCHEME_V->code == NIL)	4271	if (SCHEME_V->code == NIL)
3883	s_return (S_F);	4272	s_return (S_F);
3884		4273
…		…
3889	case OP_OR1: /* or */	4278	case OP_OR1: /* or */
3890	if (is_true (SCHEME_V->value))	4279	if (is_true (SCHEME_V->value))
3891	s_return (SCHEME_V->value);	4280	s_return (SCHEME_V->value);
3892	else if (SCHEME_V->code == NIL)	4281	else if (SCHEME_V->code == NIL)
3893	s_return (SCHEME_V->value);	4282	s_return (SCHEME_V->value);
3894	else	4283
3895	{
3896	s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));	4284	s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3897	SCHEME_V->code = car (SCHEME_V->code);	4285	SCHEME_V->code = car (SCHEME_V->code);
3898	s_goto (OP_EVAL);	4286	s_goto (OP_EVAL);
3899	}
3900		4287
3901	case OP_C0STREAM: /* cons-stream */	4288	case OP_C0STREAM: /* cons-stream */
3902	s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));	4289	s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3903	SCHEME_V->code = car (SCHEME_V->code);	4290	SCHEME_V->code = car (SCHEME_V->code);
3904	s_goto (OP_EVAL);	4291	s_goto (OP_EVAL);
…		…
3969	s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));	4356	s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3970	SCHEME_V->code = caar (x);	4357	SCHEME_V->code = caar (x);
3971	s_goto (OP_EVAL);	4358	s_goto (OP_EVAL);
3972	}	4359	}
3973	}	4360	}
3974	else	4361
3975	s_return (NIL);	4362	s_return (NIL);
3976		4363
3977	case OP_CASE2: /* case */	4364	case OP_CASE2: /* case */
3978	if (is_true (SCHEME_V->value))	4365	if (is_true (SCHEME_V->value))
3979	s_goto (OP_BEGIN);	4366	s_goto (OP_BEGIN);
3980	else	4367
3981	s_return (NIL);	4368	s_return (NIL);
3982		4369
3983	case OP_PAPPLY: /* apply */	4370	case OP_PAPPLY: /* apply */
3984	SCHEME_V->code = car (args);	4371	SCHEME_V->code = car (args);
3985	SCHEME_V->args = list_star (SCHEME_A_ cdr (args));	4372	SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3986	/*SCHEME_V->args = cadr(args); */	4373	/*SCHEME_V->args = cadr(args); */
…		…
4636	else	5023	else
4637	SCHEME_V->print_flag = 0;	5024	SCHEME_V->print_flag = 0;
4638		5025
4639	s_goto (OP_P0LIST);	5026	s_goto (OP_P0LIST);
4640		5027
		5028	//TODO: move to scheme
4641	case OP_NEWLINE: /* newline */	5029	case OP_NEWLINE: /* newline */
4642	if (is_pair (args))	5030	if (is_pair (args))
4643	{	5031	{
4644	if (a != SCHEME_V->outport)	5032	if (a != SCHEME_V->outport)
4645	{	5033	{
…		…
4647	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);	5035	s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4648	SCHEME_V->outport = a;	5036	SCHEME_V->outport = a;
4649	}	5037	}
4650	}	5038	}
4651		5039
4652	putstr (SCHEME_A_ "\n");	5040	putcharacter (SCHEME_A_ '\n');
4653	s_return (S_T);	5041	s_return (S_T);
4654	#endif	5042	#endif
4655		5043
4656	case OP_ERR0: /* error */	5044	case OP_ERR0: /* error */
4657	SCHEME_V->retcode = -1;	5045	SCHEME_V->retcode = -1;
…		…
4666	putstr (SCHEME_A_ strvalue (car (args)));	5054	putstr (SCHEME_A_ strvalue (car (args)));
4667	SCHEME_V->args = cdr (args);	5055	SCHEME_V->args = cdr (args);
4668	s_goto (OP_ERR1);	5056	s_goto (OP_ERR1);
4669		5057
4670	case OP_ERR1: /* error */	5058	case OP_ERR1: /* error */
4671	putstr (SCHEME_A_ " ");	5059	putcharacter (SCHEME_A_ ' ');
4672		5060
4673	if (args != NIL)	5061	if (args != NIL)
4674	{	5062	{
4675	s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);	5063	s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4676	SCHEME_V->args = a;	5064	SCHEME_V->args = a;
4677	SCHEME_V->print_flag = 1;	5065	SCHEME_V->print_flag = 1;
4678	s_goto (OP_P0LIST);	5066	s_goto (OP_P0LIST);
4679	}	5067	}
4680	else	5068	else
4681	{	5069	{
4682	putstr (SCHEME_A_ "\n");	5070	putcharacter (SCHEME_A_ '\n');
4683		5071
4684	if (SCHEME_V->interactive_repl)	5072	if (SCHEME_V->interactive_repl)
4685	s_goto (OP_T0LVL);	5073	s_goto (OP_T0LVL);
4686	else	5074	else
4687	return -1;	5075	return -1;
…		…
4985	case OP_RDSEXPR:	5373	case OP_RDSEXPR:
4986	switch (SCHEME_V->tok)	5374	switch (SCHEME_V->tok)
4987	{	5375	{
4988	case TOK_EOF:	5376	case TOK_EOF:
4989	s_return (S_EOF);	5377	s_return (S_EOF);
4990	/* NOTREACHED */
4991		5378
4992	case TOK_VEC:	5379	case TOK_VEC:
4993	s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);	5380	s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
4994	/* fall through */	5381	/* fall through */
4995		5382
…		…
4998		5385
4999	if (SCHEME_V->tok == TOK_RPAREN)	5386	if (SCHEME_V->tok == TOK_RPAREN)
5000	s_return (NIL);	5387	s_return (NIL);
5001	else if (SCHEME_V->tok == TOK_DOT)	5388	else if (SCHEME_V->tok == TOK_DOT)
5002	Error_0 ("syntax error: illegal dot expression");	5389	Error_0 ("syntax error: illegal dot expression");
5003	else	5390
5004	{
5005	SCHEME_V->nesting_stack[SCHEME_V->file_i]++;	5391	SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
5006	s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);	5392	s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
5007	s_goto (OP_RDSEXPR);	5393	s_goto (OP_RDSEXPR);
5008	}
5009		5394
5010	case TOK_QUOTE:	5395	case TOK_QUOTE:
5011	s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);	5396	s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
5012	SCHEME_V->tok = token (SCHEME_A);	5397	SCHEME_V->tok = token (SCHEME_A);
5013	s_goto (OP_RDSEXPR);	5398	s_goto (OP_RDSEXPR);
…		…
5019	{	5404	{
5020	s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);	5405	s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5021	SCHEME_V->tok = TOK_LPAREN;	5406	SCHEME_V->tok = TOK_LPAREN;
5022	s_goto (OP_RDSEXPR);	5407	s_goto (OP_RDSEXPR);
5023	}	5408	}
5024	else	5409
5025	s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);	5410	s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5026
5027	s_goto (OP_RDSEXPR);	5411	s_goto (OP_RDSEXPR);
5028		5412
5029	case TOK_COMMA:	5413	case TOK_COMMA:
5030	s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);	5414	s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
5031	SCHEME_V->tok = token (SCHEME_A);	5415	SCHEME_V->tok = token (SCHEME_A);
…		…
5042	case TOK_DOTATOM:	5426	case TOK_DOTATOM:
5043	SCHEME_V->strbuff[0] = '.';	5427	SCHEME_V->strbuff[0] = '.';
5044	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)));
5045		5429
5046	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
5047	x = readstrexp (SCHEME_A_ '|');	5433	x = readstrexp (SCHEME_A_ '|');
5048	//TODO: haven't checked whether the garbage collector could interfere
5049	s_return (mk_atom (SCHEME_A_ strvalue (x)));	5434	s_return (mk_atom (SCHEME_A_ strvalue (x)));
5050		5435
5051	case TOK_DQUOTE:	5436	case TOK_DQUOTE:
5052	x = readstrexp (SCHEME_A_ '"');	5437	x = readstrexp (SCHEME_A_ '"');
5053		5438
…		…
5061	{	5446	{
5062	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);
5063		5448
5064	if (f == NIL)	5449	if (f == NIL)
5065	Error_0 ("undefined sharp expression");	5450	Error_0 ("undefined sharp expression");
5066	else	5451
5067	{
5068	SCHEME_V->code = cons (slot_value_in_env (f), NIL);	5452	SCHEME_V->code = cons (slot_value_in_env (f), NIL);
5069	s_goto (OP_EVAL);	5453	s_goto (OP_EVAL);
5070	}
5071	}	5454	}
5072		5455
5073	case TOK_SHARP_CONST:	5456	case TOK_SHARP_CONST:
5074	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)
5075	Error_0 ("undefined sharp expression");	5458	Error_0 ("undefined sharp expression");
5076	else	5459
5077	s_return (x);	5460	s_return (x);
5078		5461
5079	default:	5462	default:
5080	Error_0 ("syntax error: illegal token");	5463	Error_0 ("syntax error: illegal token");
5081	}	5464	}
5082		5465
…		…
5175	pointer b = cdr (args);	5558	pointer b = cdr (args);
5176	int ok_abbr = ok_abbrev (b);	5559	int ok_abbr = ok_abbrev (b);
5177	SCHEME_V->args = car (b);	5560	SCHEME_V->args = car (b);
5178		5561
5179	if (a == SCHEME_V->QUOTE && ok_abbr)	5562	if (a == SCHEME_V->QUOTE && ok_abbr)
5180	putstr (SCHEME_A_ "'");	5563	putcharacter (SCHEME_A_ '\'');
5181	else if (a == SCHEME_V->QQUOTE && ok_abbr)	5564	else if (a == SCHEME_V->QQUOTE && ok_abbr)
5182	putstr (SCHEME_A_ "`");	5565	putcharacter (SCHEME_A_ '`');
5183	else if (a == SCHEME_V->UNQUOTE && ok_abbr)	5566	else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5184	putstr (SCHEME_A_ ",");	5567	putcharacter (SCHEME_A_ ',');
5185	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)	5568	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5186	putstr (SCHEME_A_ ",@");	5569	putstr (SCHEME_A_ ",@");
5187	else	5570	else
5188	{	5571	{
5189	putstr (SCHEME_A_ "(");	5572	putcharacter (SCHEME_A_ '(');
5190	s_save (SCHEME_A_ OP_P1LIST, b, NIL);	5573	s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5191	SCHEME_V->args = a;	5574	SCHEME_V->args = a;
5192	}	5575	}
5193		5576
5194	s_goto (OP_P0LIST);	5577	s_goto (OP_P0LIST);
…		…
5196		5579
5197	case OP_P1LIST:	5580	case OP_P1LIST:
5198	if (is_pair (args))	5581	if (is_pair (args))
5199	{	5582	{
5200	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);	5583	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5201	putstr (SCHEME_A_ " ");	5584	putcharacter (SCHEME_A_ ' ');
5202	SCHEME_V->args = car (args);	5585	SCHEME_V->args = car (args);
5203	s_goto (OP_P0LIST);	5586	s_goto (OP_P0LIST);
5204	}	5587	}
5205	else if (is_vector (args))	5588	else if (is_vector (args))
5206	{	5589	{
…		…
5214	{	5597	{
5215	putstr (SCHEME_A_ " . ");	5598	putstr (SCHEME_A_ " . ");
5216	printatom (SCHEME_A_ args, SCHEME_V->print_flag);	5599	printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5217	}	5600	}
5218		5601
5219	putstr (SCHEME_A_ ")");	5602	putcharacter (SCHEME_A_ ')');
5220	s_return (S_T);	5603	s_return (S_T);
5221	}	5604	}
5222		5605
5223	case OP_PVECFROM:	5606	case OP_PVECFROM:
5224	{	5607	{
5225	int i = ivalue_unchecked (cdr (args));	5608	IVALUE i = ivalue_unchecked (cdr (args));
5226	pointer vec = car (args);	5609	pointer vec = car (args);
5227	int len = veclength (vec);	5610	uint32_t len = veclength (vec);
5228		5611
5229	if (i == len)	5612	if (i == len)
5230	{	5613	{
5231	putstr (SCHEME_A_ ")");	5614	putcharacter (SCHEME_A_ ')');
5232	s_return (S_T);	5615	s_return (S_T);
5233	}	5616	}
5234	else	5617	else
5235	{	5618	{
5236	pointer elem = vector_get (vec, i);	5619	pointer elem = vector_get (vec, i);
5237		5620
5238	ivalue_unchecked (cdr (args)) = i + 1;	5621	set_cdr (args, mk_integer (SCHEME_A_ i + 1));
5239	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);	5622	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5240	SCHEME_V->args = elem;	5623	SCHEME_V->args = elem;
5241		5624
5242	if (i > 0)	5625	if (i > 0)
5243	putstr (SCHEME_A_ " ");	5626	putcharacter (SCHEME_A_ ' ');
5244		5627
5245	s_goto (OP_P0LIST);	5628	s_goto (OP_P0LIST);
5246	}	5629	}
5247	}	5630	}
5248	}	5631	}
…		…
5282	break;	5665	break;
5283	}	5666	}
5284		5667
5285	if (is_pair (y))	5668	if (is_pair (y))
5286	s_return (car (y));	5669	s_return (car (y));
5287	else	5670
5288	s_return (S_F);	5671	s_return (S_F);
5289
5290		5672
5291	case OP_GET_CLOSURE: /* get-closure-code *//* a.k */	5673	case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5292	SCHEME_V->args = a;	5674	SCHEME_V->args = a;
5293		5675
5294	if (SCHEME_V->args == NIL)	5676	if (SCHEME_V->args == NIL)
5295	s_return (S_F);	5677	s_return (S_F);
5296	else if (is_closure (SCHEME_V->args))	5678	else if (is_closure (SCHEME_V->args) || is_macro (SCHEME_V->args))
5297	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));	5679	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5298	else if (is_macro (SCHEME_V->args))	5680
5299	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5300	else
5301	s_return (S_F);	5681	s_return (S_F);
5302		5682
5303	case OP_CLOSUREP: /* closure? */	5683	case OP_CLOSUREP: /* closure? */
5304	/*	5684	/*
5305	* Note, macro object is also a closure.	5685	* Note, macro object is also a closure.
5306	* Therefore, (closure? <#MACRO>) ==> #t	5686	* Therefore, (closure? <#MACRO>) ==> #t
…		…
5546	static pointer	5926	static pointer
5547	mk_proc (SCHEME_P_ enum scheme_opcodes op)	5927	mk_proc (SCHEME_P_ enum scheme_opcodes op)
5548	{	5928	{
5549	pointer y = get_cell (SCHEME_A_ NIL, NIL);	5929	pointer y = get_cell (SCHEME_A_ NIL, NIL);
5550	set_typeflag (y, (T_PROC | T_ATOM));	5930	set_typeflag (y, (T_PROC | T_ATOM));
5551	ivalue_unchecked (y) = op;	5931	set_ivalue (y, op);
5552	return y;	5932	return y;
5553	}	5933	}
5554		5934
5555	/* 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! */
5556	ecb_hot static int	5936	ecb_hot static int
…		…
5640		6020
5641	ecb_cold int	6021	ecb_cold int
5642	scheme_init (SCHEME_P)	6022	scheme_init (SCHEME_P)
5643	{	6023	{
5644	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	6024	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5645	pointer x;
5646		6025
5647	/* this memset is not strictly correct, as we assume (intcache)	6026	/* this memset is not strictly correct, as we assume (intcache)
5648	* 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
5649	* of course not guarantee that. screw such systems.	6028	* of course not guarantee that. screw such systems.
5650	*/	6029	*/
…		…
5678	#endif	6057	#endif
5679	}	6058	}
5680		6059
5681	SCHEME_V->gc_verbose = 0;	6060	SCHEME_V->gc_verbose = 0;
5682	dump_stack_initialize (SCHEME_A);	6061	dump_stack_initialize (SCHEME_A);
5683	SCHEME_V->code = NIL;	6062	SCHEME_V->code = NIL;
5684	SCHEME_V->args = NIL;	6063	SCHEME_V->args = NIL;
5685	SCHEME_V->envir = NIL;	6064	SCHEME_V->envir = NIL;
		6065	SCHEME_V->value = NIL;
5686	SCHEME_V->tracing = 0;	6066	SCHEME_V->tracing = 0;
5687		6067
5688	/* init NIL */	6068	/* init NIL */
5689	set_typeflag (NIL, T_ATOM | T_MARK);	6069	set_typeflag (NIL, T_SPECIAL | T_ATOM);
5690	set_car (NIL, NIL);	6070	set_car (NIL, NIL);
5691	set_cdr (NIL, NIL);	6071	set_cdr (NIL, NIL);
5692	/* init T */	6072	/* init T */
5693	set_typeflag (S_T, T_ATOM | T_MARK);	6073	set_typeflag (S_T, T_SPECIAL | T_ATOM);
5694	set_car (S_T, S_T);	6074	set_car (S_T, S_T);
5695	set_cdr (S_T, S_T);	6075	set_cdr (S_T, S_T);
5696	/* init F */	6076	/* init F */
5697	set_typeflag (S_F, T_ATOM | T_MARK);	6077	set_typeflag (S_F, T_SPECIAL | T_ATOM);
5698	set_car (S_F, S_F);	6078	set_car (S_F, S_F);
5699	set_cdr (S_F, S_F);	6079	set_cdr (S_F, S_F);
5700	/* init EOF_OBJ */	6080	/* init EOF_OBJ */
5701	set_typeflag (S_EOF, T_ATOM | T_MARK);	6081	set_typeflag (S_EOF, T_SPECIAL | T_ATOM);
5702	set_car (S_EOF, S_EOF);	6082	set_car (S_EOF, S_EOF);
5703	set_cdr (S_EOF, S_EOF);	6083	set_cdr (S_EOF, S_EOF);
5704	/* init sink */	6084	/* init sink */
5705	set_typeflag (S_SINK, T_PAIR | T_MARK);	6085	set_typeflag (S_SINK, T_PAIR);
5706	set_car (S_SINK, NIL);	6086	set_car (S_SINK, NIL);
5707		6087
5708	/* init c_nest */	6088	/* init c_nest */
5709	SCHEME_V->c_nest = NIL;	6089	SCHEME_V->c_nest = NIL;
5710		6090
5711	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);	6091	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5712	/* init global_env */	6092	/* init global_env */
5713	new_frame_in_env (SCHEME_A_ NIL);	6093	new_frame_in_env (SCHEME_A_ NIL);
5714	SCHEME_V->global_env = SCHEME_V->envir;	6094	SCHEME_V->global_env = SCHEME_V->envir;
5715	/* init else */	6095	/* init else */
5716	x = mk_symbol (SCHEME_A_ "else");	6096	new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), S_T);
5717	new_slot_in_env (SCHEME_A_ x, S_T);
5718		6097
5719	{	6098	{
5720	static const char *syntax_names[] = {	6099	static const char *syntax_names[] = {
5721	"lambda", "quote", "define", "if", "begin", "set!",	6100	"lambda", "quote", "define", "if", "begin", "set!",
5722	"let", "let*", "letrec", "cond", "delay", "and",	6101	"let", "let*", "letrec", "cond", "delay", "and",
…		…
5813	SCHEME_V->loadport = NIL;	6192	SCHEME_V->loadport = NIL;
5814	SCHEME_V->gc_verbose = 0;	6193	SCHEME_V->gc_verbose = 0;
5815	gc (SCHEME_A_ NIL, NIL);	6194	gc (SCHEME_A_ NIL, NIL);
5816		6195
5817	for (i = 0; i <= SCHEME_V->last_cell_seg; i++)	6196	for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5818	free (SCHEME_V->alloc_seg[i]);	6197	free (SCHEME_V->cell_seg[i]);
5819		6198
5820	#if SHOW_ERROR_LINE	6199	#if SHOW_ERROR_LINE
5821	for (i = 0; i <= SCHEME_V->file_i; i++)	6200	for (i = 0; i <= SCHEME_V->file_i; i++)
5822	{
5823	if (SCHEME_V->load_stack[i].kind & port_file)	6201	if (SCHEME_V->load_stack[i].kind & port_file)
5824	{	6202	{
5825	fname = SCHEME_V->load_stack[i].rep.stdio.filename;	6203	fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5826		6204
5827	if (fname)	6205	if (fname)
5828	free (fname);	6206	free (fname);
5829	}	6207	}
5830	}
5831	#endif	6208	#endif
5832	}	6209	}
5833		6210
5834	ecb_cold void	6211	ecb_cold void
5835	scheme_load_file (SCHEME_P_ int fin)	6212	scheme_load_file (SCHEME_P_ int fin)
…		…
5844	SCHEME_V->envir = SCHEME_V->global_env;	6221	SCHEME_V->envir = SCHEME_V->global_env;
5845	SCHEME_V->file_i = 0;	6222	SCHEME_V->file_i = 0;
5846	SCHEME_V->load_stack[0].unget = -1;	6223	SCHEME_V->load_stack[0].unget = -1;
5847	SCHEME_V->load_stack[0].kind = port_input | port_file;	6224	SCHEME_V->load_stack[0].kind = port_input | port_file;
5848	SCHEME_V->load_stack[0].rep.stdio.file = fin;	6225	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);	6226	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5851	#endif
5852	SCHEME_V->retcode = 0;	6227	SCHEME_V->retcode = 0;
5853		6228
5854	#if USE_PORTS
5855	if (fin == STDIN_FILENO)	6229	if (fin == STDIN_FILENO)
5856	SCHEME_V->interactive_repl = 1;	6230	SCHEME_V->interactive_repl = 1;
5857	#endif
5858		6231
5859	#if USE_PORTS	6232	#if USE_PORTS
5860	#if SHOW_ERROR_LINE	6233	#if SHOW_ERROR_LINE
5861	SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;	6234	SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5862		6235
…		…
5866	#endif	6239	#endif
5867		6240
5868	SCHEME_V->inport = SCHEME_V->loadport;	6241	SCHEME_V->inport = SCHEME_V->loadport;
5869	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	6242	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5870	Eval_Cycle (SCHEME_A_ OP_T0LVL);	6243	Eval_Cycle (SCHEME_A_ OP_T0LVL);
		6244
5871	set_typeflag (SCHEME_V->loadport, T_ATOM);	6245	set_typeflag (SCHEME_V->loadport, T_ATOM);
5872		6246
5873	if (SCHEME_V->retcode == 0)	6247	if (SCHEME_V->retcode == 0)
5874	SCHEME_V->retcode = SCHEME_V->nesting != 0;	6248	SCHEME_V->retcode = SCHEME_V->nesting != 0;
5875	}	6249	}
5876		6250
5877	ecb_cold void	6251	ecb_cold void
5878	scheme_load_string (SCHEME_P_ const char *cmd)	6252	scheme_load_string (SCHEME_P_ const char *cmd)
5879	{	6253	{
		6254	#if USE_PORTs
5880	dump_stack_reset (SCHEME_A);	6255	dump_stack_reset (SCHEME_A);
5881	SCHEME_V->envir = SCHEME_V->global_env;	6256	SCHEME_V->envir = SCHEME_V->global_env;
5882	SCHEME_V->file_i = 0;	6257	SCHEME_V->file_i = 0;
5883	SCHEME_V->load_stack[0].kind = port_input | port_string;	6258	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 */	6259	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);	6260	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;	6261	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);	6262	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5889	#endif
5890	SCHEME_V->retcode = 0;	6263	SCHEME_V->retcode = 0;
5891	SCHEME_V->interactive_repl = 0;	6264	SCHEME_V->interactive_repl = 0;
5892	SCHEME_V->inport = SCHEME_V->loadport;	6265	SCHEME_V->inport = SCHEME_V->loadport;
5893	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);	6266	SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5894	Eval_Cycle (SCHEME_A_ OP_T0LVL);	6267	Eval_Cycle (SCHEME_A_ OP_T0LVL);
5895	set_typeflag (SCHEME_V->loadport, T_ATOM);	6268	set_typeflag (SCHEME_V->loadport, T_ATOM);
5896		6269
5897	if (SCHEME_V->retcode == 0)	6270	if (SCHEME_V->retcode == 0)
5898	SCHEME_V->retcode = SCHEME_V->nesting != 0;	6271	SCHEME_V->retcode = SCHEME_V->nesting != 0;
		6272	#else
		6273	abort ();
		6274	#endif
5899	}	6275	}
5900		6276
5901	ecb_cold void	6277	ecb_cold void
5902	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)	6278	scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5903	{	6279	{
…		…
6008	# endif	6384	# endif
6009	int fin;	6385	int fin;
6010	char *file_name = InitFile;	6386	char *file_name = InitFile;
6011	int retcode;	6387	int retcode;
6012	int isfile = 1;	6388	int isfile = 1;
		6389	#if EXPERIMENT
6013	system ("ps v $PPID");//D	6390	system ("ps v $PPID");
		6391	#endif
6014		6392
6015	if (argc == 2 && strcmp (argv[1], "-?") == 0)	6393	if (argc == 2 && strcmp (argv[1], "-?") == 0)
6016	{	6394	{
6017	putstr (SCHEME_A_ "Usage: tinyscheme -?\n");	6395	putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6018	putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");	6396	putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
…		…
6047	}	6425	}
6048	#endif	6426	#endif
6049		6427
6050	do	6428	do
6051	{	6429	{
6052	#if USE_PORTS
6053	if (strcmp (file_name, "-") == 0)	6430	if (strcmp (file_name, "-") == 0)
6054	fin = STDIN_FILENO;	6431	fin = STDIN_FILENO;
6055	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)
6056	{	6433	{
6057	pointer args = NIL;	6434	pointer args = NIL;
…		…
6075	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);
6076		6453
6077	}	6454	}
6078	else	6455	else
6079	fin = open (file_name, O_RDONLY);	6456	fin = open (file_name, O_RDONLY);
6080	#endif
6081		6457
6082	if (isfile && fin < 0)	6458	if (isfile && fin < 0)
6083	{	6459	{
6084	putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");	6460	putstr (SCHEME_A_ "Could not open file ");
		6461	putstr (SCHEME_A_ file_name);
		6462	putcharacter (SCHEME_A_ '\n');
6085	}	6463	}
6086	else	6464	else
6087	{	6465	{
6088	if (isfile)	6466	if (isfile)
6089	scheme_load_named_file (SCHEME_A_ fin, file_name);	6467	scheme_load_named_file (SCHEME_A_ fin, file_name);
6090	else	6468	else
6091	scheme_load_string (SCHEME_A_ file_name);	6469	scheme_load_string (SCHEME_A_ file_name);
6092		6470
6093	#if USE_PORTS
6094	if (!isfile || fin != STDIN_FILENO)	6471	if (!isfile || fin != STDIN_FILENO)
6095	{	6472	{
6096	if (SCHEME_V->retcode != 0)	6473	if (SCHEME_V->retcode != 0)
6097	{	6474	{
6098	putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");	6475	putstr (SCHEME_A_ "Errors encountered reading ");
		6476	putstr (SCHEME_A_ file_name);
		6477	putcharacter (SCHEME_A_ '\n');
6099	}	6478	}
6100		6479
6101	if (isfile)	6480	if (isfile)
6102	close (fin);	6481	close (fin);
6103	}	6482	}
6104	#endif
6105	}	6483	}
6106		6484
6107	file_name = *argv++;	6485	file_name = *argv++;
6108	}	6486	}
6109	while (file_name != 0);	6487	while (file_name != 0);

Diff Legend

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