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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.61 by root, Wed Dec 2 07:43:46 2015 UTC vs.
Revision 1.66 by root, Mon Dec 7 18:10:57 2015 UTC

…		…
16	* (MINISCM) This is a revised and modified version by Akira KIDA.	16	* (MINISCM) This is a revised and modified version by Akira KIDA.
17	* (MINISCM) current version is 0.85k4 (15 May 1994)	17	* (MINISCM) current version is 0.85k4 (15 May 1994)
18	*	18	*
19	*/	19	*/
20		20
21	#define _GNU_SOURCE 1
22	#define _POSIX_C_SOURCE 200201	21	#define _POSIX_C_SOURCE 200201
23	#define _XOPEN_SOURCE 600	22	#define _XOPEN_SOURCE 600
24		23	#define _GNU_SOURCE 1 /* for malloc mremap */
25		24
26	#define SCHEME_SOURCE	25	#define SCHEME_SOURCE
27	#include "scheme-private.h"	26	#include "scheme-private.h"
28	#ifndef WIN32	27	#ifndef WIN32
29	# include <unistd.h>	28	# include <unistd.h>
30	#endif	29	#endif
31	#if USE_MATH	30	#if USE_MATH
32	# include <math.h>	31	# include <math.h>
33	#endif	32	#endif
34		33
		34	#define ECB_NO_THREADS 1
35	#include "ecb.h"	35	#include "ecb.h"
36		36
37	#include <sys/types.h>	37	#include <sys/types.h>
38	#include <sys/stat.h>	38	#include <sys/stat.h>
39	#include <fcntl.h>	39	#include <fcntl.h>
…		…
194	# define stricmp(a,b) strcmp (a, b)	194	# define stricmp(a,b) strcmp (a, b)
195	# define strlwr(s) (s)	195	# define strlwr(s) (s)
196	#endif	196	#endif
197		197
198	#ifndef prompt	198	#ifndef prompt
199	# define prompt "ts> "	199	# define prompt "ms> "
200	#endif	200	#endif
201		201
202	#ifndef InitFile	202	#ifndef InitFile
203	# define InitFile "init.scm"	203	# define InitFile "init.scm"
204	#endif	204	#endif
…		…
219	T_FOREIGN,	219	T_FOREIGN,
220	T_PORT,	220	T_PORT,
221	T_VECTOR,	221	T_VECTOR,
222	T_PROMISE,	222	T_PROMISE,
223	T_ENVIRONMENT,	223	T_ENVIRONMENT,
		224	T_SPECIAL, // #t, #f, '(), eof-object
224		225
225	T_NUM_SYSTEM_TYPES	226	T_NUM_SYSTEM_TYPES
226	};	227	};
227		228
228	#define T_MASKTYPE 0x000f	229	#define T_MASKTYPE 0x001f
229	#define T_SYNTAX 0x0010	230	#define T_SYNTAX 0x0020
230	#define T_IMMUTABLE 0x0020	231	#define T_IMMUTABLE 0x0040
231	#define T_ATOM 0x0040 /* only for gc */	232	#define T_ATOM 0x0080 /* only for gc */
232	#define T_MARK 0x0080 /* only for gc */	233	//#define T_MARK 0x0080 /* only for gc */
233		234
234	/* num, for generic arithmetic */	235	/* num, for generic arithmetic */
235	struct num	236	struct num
236	{	237	{
237	IVALUE ivalue;	238	IVALUE ivalue;
…		…
383		384
384	static pointer cadar (pointer p) { return car (cdr (car (p))); }	385	static pointer cadar (pointer p) { return car (cdr (car (p))); }
385	static pointer caddr (pointer p) { return car (cdr (cdr (p))); }	386	static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
386	static pointer cdaar (pointer p) { return cdr (car (car (p))); }	387	static pointer cdaar (pointer p) { return cdr (car (car (p))); }
387		388
		389	static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); }
		390
388	INTERFACE void	391	INTERFACE void
389	set_car (pointer p, pointer q)	392	set_car (pointer p, pointer q)
390	{	393	{
391	CELL(p)->object.cons.car = CELL (q);	394	CELL(p)->object.cons.car = CELL (q);
392	}	395	}
…		…
508		511
509	#define is_atom(p) (typeflag (p) & T_ATOM)	512	#define is_atom(p) (typeflag (p) & T_ATOM)
510	#define setatom(p) set_typeflag ((p), typeflag (p) \| T_ATOM)	513	#define setatom(p) set_typeflag ((p), typeflag (p) \| T_ATOM)
511	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)	514	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
512		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
513	#define is_mark(p) (typeflag (p) & T_MARK)	521	#define is_mark(p) (typeflag (p) & T_MARK)
514	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)	522	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)
515	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	523	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
		524	#endif
516		525
517	INTERFACE int	526	INTERFACE int
518	is_immutable (pointer p)	527	is_immutable (pointer p)
519	{	528	{
520	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	529	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
…		…
707	static int basic_inchar (port *pt);	716	static int basic_inchar (port *pt);
708	static int inchar (SCHEME_P);	717	static int inchar (SCHEME_P);
709	static void backchar (SCHEME_P_ int c);	718	static void backchar (SCHEME_P_ int c);
710	static char readstr_upto (SCHEME_P_ int skip, const char delim);	719	static char readstr_upto (SCHEME_P_ int skip, const char delim);
711	static pointer readstrexp (SCHEME_P_ char delim);	720	static pointer readstrexp (SCHEME_P_ char delim);
712	ecb_inline int skipspace (SCHEME_P);	721	static int skipspace (SCHEME_P);
713	static int token (SCHEME_P);	722	static int token (SCHEME_P);
714	static void printslashstring (SCHEME_P_ char *s, int len);	723	static void printslashstring (SCHEME_P_ char *s, int len);
715	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);
716	static void printatom (SCHEME_P_ pointer l, int f);	725	static void printatom (SCHEME_P_ pointer l, int f);
717	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	726	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
916		925
917	if (!cp && USE_ERROR_CHECKING)	926	if (!cp && USE_ERROR_CHECKING)
918	return k;	927	return k;
919		928
920	i = ++SCHEME_V->last_cell_seg;	929	i = ++SCHEME_V->last_cell_seg;
921	SCHEME_V->alloc_seg[i] = cp;
922		930
923	newp = (struct cell *)cp;	931	newp = (struct cell *)cp;
924	SCHEME_V->cell_seg[i] = newp;	932	SCHEME_V->cell_seg[i] = newp;
925	SCHEME_V->cell_segsize[i] = segsize;	933	SCHEME_V->cell_segsize[i] = segsize;
926	SCHEME_V->fcells += segsize;	934	SCHEME_V->fcells += segsize;
927	last = newp + segsize - 1;	935	last = newp + segsize - 1;
928		936
929	for (p = newp; p <= last; p++)	937	for (p = newp; p <= last; p++)
930	{	938	{
931	pointer cp = POINTER (p);	939	pointer cp = POINTER (p);
		940	clrmark (cp);
932	set_typeflag (cp, T_PAIR);	941	set_typeflag (cp, T_PAIR);
933	set_car (cp, NIL);	942	set_car (cp, NIL);
934	set_cdr (cp, POINTER (p + 1));	943	set_cdr (cp, POINTER (p + 1));
935	}	944	}
936		945
…		…
1098		1107
1099	static int	1108	static int
1100	hash_fn (const char *key, int table_size)	1109	hash_fn (const char *key, int table_size)
1101	{	1110	{
1102	const unsigned char p = (unsigned char )key;	1111	const unsigned char p = (unsigned char )key;
1103	uint32_t hash = 2166136261;	1112	uint32_t hash = 2166136261U;
1104		1113
1105	while (*p)	1114	while (*p)
1106	hash = (hash ^ p++) 16777619;	1115	hash = (hash ^ p++) 16777619;
1107		1116
1108	return hash % table_size;	1117	return hash % table_size;
…		…
2164	case 'a': *p++ = '\a'; state = st_ok; break;	2173	case 'a': *p++ = '\a'; state = st_ok; break;
2165	case 'n': *p++ = '\n'; state = st_ok; break;	2174	case 'n': *p++ = '\n'; state = st_ok; break;
2166	case 'r': *p++ = '\r'; state = st_ok; break;	2175	case 'r': *p++ = '\r'; state = st_ok; break;
2167	case 't': *p++ = '\t'; state = st_ok; break;	2176	case 't': *p++ = '\t'; state = st_ok; break;
2168		2177
		2178	// this overshoots the minimum requirements of r7rs
		2179	case ' ':
2169	case '\\':	2180	case '\t':
		2181	case '\r':
		2182	case '\n':
2170	skipspace (SCHEME_A);	2183	skipspace (SCHEME_A);
		2184	state = st_ok;
2171	break;	2185	break;
2172		2186
2173	//TODO: x should end in ;, not two-digit hex	2187	//TODO: x should end in ;, not two-digit hex
2174	case 'x':	2188	case 'x':
2175	case 'X':	2189	case 'X':
…		…
2932	/* ========== Evaluation Cycle ========== */	2946	/* ========== Evaluation Cycle ========== */
2933		2947
2934	ecb_cold static int	2948	ecb_cold static int
2935	xError_1 (SCHEME_P_ const char *s, pointer a)	2949	xError_1 (SCHEME_P_ const char *s, pointer a)
2936	{	2950	{
2937	#if USE_ERROR_HOOK
2938	pointer x;
2939	pointer hdl = SCHEME_V->ERROR_HOOK;
2940	#endif
2941
2942	#if USE_PRINTF	2951	#if USE_PRINTF
2943	#if SHOW_ERROR_LINE	2952	#if SHOW_ERROR_LINE
2944	char sbuf[STRBUFFSIZE];	2953	char sbuf[STRBUFFSIZE];
2945		2954
2946	/* make sure error is not in REPL */	2955	/* make sure error is not in REPL */
…		…
2961	}	2970	}
2962	#endif	2971	#endif
2963	#endif	2972	#endif
2964		2973
2965	#if USE_ERROR_HOOK	2974	#if USE_ERROR_HOOK
2966	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);	2975	pointer x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->ERROR_HOOK, 1);
2967		2976
2968	if (x != NIL)	2977	if (x != NIL)
2969	{	2978	{
2970	pointer code = a	2979	pointer code = a
2971	? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)	2980	? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
…		…
3215		3224
3216	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3225	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3217		3226
3218	#if EXPERIMENT	3227	#if EXPERIMENT
3219		3228
3220	typedef void *stream[1];
3221
3222	#define stream_init() { 0 }
3223
3224	ecb_cold static void
3225	stream_put (void **s, uint8_t byte)
3226	{
3227	uint32_t sp = s;
3228	uint32_t size = sizeof (uint32_t) * 2;
3229	uint32_t offs = size;
3230
3231	if (ecb_expect_true (sp))
3232	{
3233	offs = sp[0];
3234	size = sp[1];
3235	}
3236
3237	if (ecb_expect_false (offs == size))
3238	{
3239	size *= 2;
3240	sp = realloc (sp, size);
3241	*s = sp;
3242	sp[1] = size;
3243
3244	}
3245
3246	((uint8_t *)sp)[offs++] = byte;
3247	sp[0] = offs;
3248	}
3249
3250	#define stream_data(s) ((char )(s)[0] + sizeof (uint32_t) 2)
3251	#define stream_size(s) (((uint32_t )(s)[0])[0] - sizeof (uint32_t) 2)
3252	#define stream_free(s) free (s[0])
3253
3254	// calculates a (preferably small) integer that makes it possible to find
3255	// the symbol again. if pointers were offsets into a memory area... until
3256	// then, we return segment number in the low bits, and offset in the high
3257	// bits
3258	static uint32_t
3259	symbol_id (SCHEME_P_ pointer sym)
3260	{
3261	struct cell *p = CELL (sym);
3262	int i;
3263
3264	for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3265	if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3266	{
3267	printf ("seg %d ofs %d/%d\n",i,(p - SCHEME_V->cell_seg[i]),SCHEME_V->cell_segsize[i]);//D
3268	return i \| ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3269	}
3270
3271	abort ();
3272	}
3273
3274	static void
3275	compile (SCHEME_P_ stream s, pointer x)
3276	{
3277	if (x == NIL)
3278	{
3279	stream_put (s, 0);
3280	return;
3281	}
3282
3283	if (is_syntax (x))
3284	{
3285	stream_put (s, 1);
3286	stream_put (s, syntaxnum (x));
3287	return;
3288	}
3289
3290	switch (type (x))
3291	{
3292	case T_INTEGER:
3293	stream_put (s, 2);
3294	stream_put (s, 0);
3295	stream_put (s, 0);
3296	stream_put (s, 0);
3297	stream_put (s, 0);
3298	return;
3299
3300	case T_SYMBOL:
3301	{
3302	uint32_t sym = symbol_id (SCHEME_A_ x);
3303	printf ("sym %x\n", sym);//D
3304
3305	stream_put (s, 3);
3306
3307	while (sym > 0x7f)
3308	{
3309	stream_put (s, sym \| 0x80);
3310	sym >>= 8;
3311	}
3312
3313	stream_put (s, sym);
3314	}
3315	return;
3316
3317	case T_PAIR:
3318	stream_put (s, 4);
3319	while (x != NIL)
3320	{
3321	compile (SCHEME_A_ s, car (x));
3322	x = cdr (x);
3323	}
3324	stream_put (s, 0xff);
3325	return;
3326
3327	default:
3328	stream_put (s, 5);
3329	stream_put (s, type (x));
3330	stream_put (s, 0);
3331	stream_put (s, 0);
3332	stream_put (s, 0);
3333	stream_put (s, 0);
3334	break;
3335	}
3336	}
3337
3338	static int
3339	compile_closure (SCHEME_P_ pointer p)
3340	{
3341	stream s = stream_init ();
3342
3343	printatom (SCHEME_A_ p, 1);//D
3344	compile (SCHEME_A_ s, car (p));
3345
3346	FILE *xxd = popen ("xxd", "we");
3347	fwrite (stream_data (s), 1, stream_size (s), xxd);
3348	fclose (xxd);
3349
3350	return stream_size (s);
3351	}
3352
3353	static int	3229	static int
3354	dtree (SCHEME_P_ int indent, pointer x)	3230	dtree (SCHEME_P_ int indent, pointer x)
3355	{	3231	{
3356	int c;	3232	int c;
3357		3233
…		…
3403	default:	3279	default:
3404	printf ("unhandled type %d\n", type (x));	3280	printf ("unhandled type %d\n", type (x));
3405	break;	3281	break;
3406	}	3282	}
3407	}	3283	}
		3284
		3285	#define DUMP(t) do { printf ("DUMP %s:%d\n", __FILE__, __LINE__); dtree (SCHEME_A_ 0, (t)); } while (0)
		3286
		3287	typedef void *stream[1];
		3288
		3289	#define stream_init() { 0 }
		3290	#define stream_data(s) ((char )(s)[0] + sizeof (uint32_t) 2)
		3291	#define stream_size(s) (((uint32_t )(s)[0])[0] - sizeof (uint32_t) 2)
		3292	#define stream_free(s) free (s[0])
		3293
		3294	ecb_cold static void
		3295	stream_put (stream s, uint8_t byte)
		3296	{
		3297	uint32_t sp = s;
		3298	uint32_t size = sizeof (uint32_t) * 2;
		3299	uint32_t offs = size;
		3300
		3301	if (ecb_expect_true (sp))
		3302	{
		3303	offs = sp[0];
		3304	size = sp[1];
		3305	}
		3306
		3307	if (ecb_expect_false (offs == size))
		3308	{
		3309	size *= 2;
		3310	sp = realloc (sp, size);
		3311	*s = sp;
		3312	sp[1] = size;
		3313
		3314	}
		3315
		3316	((uint8_t *)sp)[offs++] = byte;
		3317	sp[0] = offs;
		3318	}
		3319
		3320	ecb_cold static void
		3321	stream_put_v (stream s, uint32_t v)
		3322	{
		3323	while (v > 0x7f)
		3324	{
		3325	stream_put (s, v \| 0x80);
		3326	v >>= 7;
		3327	}
		3328
		3329	stream_put (s, v);
		3330	}
		3331
		3332	ecb_cold static void
		3333	stream_put_tv (stream s, int bop, uint32_t v)
		3334	{
		3335	printf ("put tv %d %d\n", bop, v);//D
		3336	stream_put (s, bop);
		3337	stream_put_v (s, v);
		3338	}
		3339
		3340	ecb_cold static void
		3341	stream_put_stream (stream s, stream o)
		3342	{
		3343	uint32_t i;
		3344
		3345	for (i = 0; i < stream_size (o); ++i)
		3346	stream_put (s, stream_data (o)[i]);
		3347
		3348	stream_free (o);
		3349	}
		3350
		3351	ecb_cold static uint32_t
		3352	cell_id (SCHEME_P_ pointer x)
		3353	{
		3354	struct cell *p = CELL (x);
		3355	int i;
		3356
		3357	for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
		3358	if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
		3359	return i \| ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
		3360
		3361	abort ();
		3362	}
		3363
		3364	// calculates a (preferably small) integer that makes it possible to find
		3365	// the symbol again. if pointers were offsets into a memory area... until
		3366	// then, we return segment number in the low bits, and offset in the high
		3367	// bits.
		3368	// also, this function must never return 0.
		3369	ecb_cold static uint32_t
		3370	symbol_id (SCHEME_P_ pointer sym)
		3371	{
		3372	return cell_id (SCHEME_A_ sym);
		3373	}
		3374
		3375	enum byteop
		3376	{
		3377	BOP_NIL,
		3378	BOP_INTEGER,
		3379	BOP_SYMBOL,
		3380	BOP_DATUM,
		3381	BOP_LIST_BEG,
		3382	BOP_LIST_END,
		3383	BOP_IF,
		3384	BOP_AND,
		3385	BOP_OR,
		3386	BOP_CASE,
		3387	BOP_COND,
		3388	BOP_LET,
		3389	BOP_LETAST,
		3390	BOP_LETREC,
		3391	BOP_DEFINE,
		3392	BOP_MACRO,
		3393	BOP_SET,
		3394	BOP_BEGIN,
		3395	BOP_LAMBDA,
		3396	BOP_OP,
		3397	};
		3398
		3399	ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
		3400
		3401	ecb_cold static void
		3402	compile_list (SCHEME_P_ stream s, pointer x)
		3403	{
		3404	// TODO: improper list
		3405
		3406	for (; x != NIL; x = cdr (x))
		3407	{
		3408	stream t = stream_init ();
		3409	compile_expr (SCHEME_A_ t, car (x));
		3410	stream_put_v (s, stream_size (t));
		3411	stream_put_stream (s, t);
		3412	}
		3413
		3414	stream_put_v (s, 0);
		3415	}
		3416
		3417	static void
		3418	compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
		3419	{
		3420	stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
		3421
		3422	stream_put (s, BOP_IF);
		3423	compile_expr (SCHEME_A_ s, cond);
		3424	stream_put_v (s, stream_size (sift));
		3425	stream_put_stream (s, sift);
		3426	compile_expr (SCHEME_A_ s, iff);
		3427	}
		3428
		3429	typedef uint32_t stream_fixup;
		3430
		3431	static stream_fixup
		3432	stream_put_fixup (stream s)
		3433	{
		3434	stream_put (s, 0);
		3435	stream_put (s, 0);
		3436
		3437	return stream_size (s);
		3438	}
		3439
		3440	static void
		3441	stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target)
		3442	{
		3443	target -= fixup;
		3444	assert (target < (1 << 14));
		3445	stream_data (s)[fixup - 2] = target \| 0x80;
		3446	stream_data (s)[fixup - 1] = target >> 7;
		3447	}
		3448
		3449	static void
		3450	compile_and_or (SCHEME_P_ stream s, int and, pointer x)
		3451	{
		3452	for (; cdr (x) != NIL; x = cdr (x))
		3453	{
		3454	stream t = stream_init ();
		3455	compile_expr (SCHEME_A_ t, car (x));
		3456	stream_put_v (s, stream_size (t));
		3457	stream_put_stream (s, t);
		3458	}
		3459
		3460	stream_put_v (s, 0);
		3461	}
		3462
		3463	static void
		3464	compile_case (SCHEME_P_ stream s, pointer x)
		3465	{
		3466	compile_expr (SCHEME_A_ s, caar (x));
		3467
		3468	for (;;)
		3469	{
		3470	x = cdr (x);
		3471
		3472	if (x == NIL)
		3473	break;
		3474
		3475	compile_expr (SCHEME_A_ s, caar (x));
		3476	stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
		3477	stream_put_v (s, stream_size (t));
		3478	stream_put_stream (s, t);
		3479	}
		3480
		3481	stream_put_v (s, 0);
		3482	}
		3483
		3484	static void
		3485	compile_cond (SCHEME_P_ stream s, pointer x)
		3486	{
		3487	for ( ; x != NIL; x = cdr (x))
		3488	{
		3489	compile_expr (SCHEME_A_ s, caar (x));
		3490	stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
		3491	stream_put_v (s, stream_size (t));
		3492	stream_put_stream (s, t);
		3493	}
		3494
		3495	stream_put_v (s, 0);
		3496	}
		3497
		3498	static pointer
		3499	lookup (SCHEME_P_ pointer x)
		3500	{
		3501	x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, x, 1);
		3502
		3503	if (x != NIL)
		3504	x = slot_value_in_env (x);
		3505
		3506	return x;
		3507	}
		3508
		3509	ecb_cold static void
		3510	compile_expr (SCHEME_P_ stream s, pointer x)
		3511	{
		3512	if (x == NIL)
		3513	{
		3514	stream_put (s, BOP_NIL);
		3515	return;
		3516	}
		3517
		3518	if (is_pair (x))
		3519	{
		3520	pointer head = car (x);
		3521
		3522	if (is_syntax (head))
		3523	{
		3524	x = cdr (x);
		3525
		3526	switch (syntaxnum (head))
		3527	{
		3528	case OP_IF0: /* if */
		3529	stream_put_v (s, BOP_IF);
		3530	compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
		3531	break;
		3532
		3533	case OP_OR0: /* or */
		3534	stream_put_v (s, BOP_OR);
		3535	compile_and_or (SCHEME_A_ s, 0, x);
		3536	break;
		3537
		3538	case OP_AND0: /* and */
		3539	stream_put_v (s, BOP_AND);
		3540	compile_and_or (SCHEME_A_ s, 1, x);
		3541	break;
		3542
		3543	case OP_CASE0: /* case */
		3544	stream_put_v (s, BOP_CASE);
		3545	compile_case (SCHEME_A_ s, x);
		3546	break;
		3547
		3548	case OP_COND0: /* cond */
		3549	stream_put_v (s, BOP_COND);
		3550	compile_cond (SCHEME_A_ s, x);
		3551	break;
		3552
		3553	case OP_LET0: /* let */
		3554	case OP_LET0AST: /* let* */
		3555	case OP_LET0REC: /* letrec */
		3556	switch (syntaxnum (head))
		3557	{
		3558	case OP_LET0: stream_put (s, BOP_LET ); break;
		3559	case OP_LET0AST: stream_put (s, BOP_LETAST); break;
		3560	case OP_LET0REC: stream_put (s, BOP_LETREC); break;
		3561	}
		3562
		3563	{
		3564	pointer bindings = car (x);
		3565	pointer body = cadr (x);
		3566
		3567	for (x = bindings; x != NIL; x = cdr (x))
		3568	{
		3569	pointer init = NIL;
		3570	pointer var = car (x);
		3571
		3572	if (is_pair (var))
		3573	{
		3574	init = cdr (var);
		3575	var = car (var);
		3576	}
		3577
		3578	stream_put_v (s, symbol_id (SCHEME_A_ var));
		3579	compile_expr (SCHEME_A_ s, init);
		3580	}
		3581
		3582	stream_put_v (s, 0);
		3583	compile_expr (SCHEME_A_ s, body);
		3584	}
		3585	break;
		3586
		3587	case OP_DEF0: /* define */
		3588	case OP_MACRO0: /* macro */
		3589	stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO);
		3590	stream_put_v (s, cell_id (SCHEME_A_ car (x)));
		3591	compile_expr (SCHEME_A_ s, cadr (x));
		3592	break;
		3593
		3594	case OP_SET0: /* set! */
		3595	stream_put (s, BOP_SET);
		3596	stream_put_v (s, symbol_id (SCHEME_A_ car (x)));
		3597	compile_expr (SCHEME_A_ s, cadr (x));
		3598	break;
		3599
		3600	case OP_BEGIN: /* begin */
		3601	stream_put (s, BOP_BEGIN);
		3602	compile_list (SCHEME_A_ s, x);
		3603	return;
		3604
		3605	case OP_DELAY: /* delay */
		3606	abort ();
		3607	break;
		3608
		3609	case OP_QUOTE: /* quote */
		3610	stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
		3611	break;
		3612
		3613	case OP_LAMBDA: /* lambda */
		3614	{
		3615	pointer formals = car (x);
		3616	pointer body = cadr (x);
		3617
		3618	stream_put (s, BOP_LAMBDA);
		3619
		3620	for (; is_pair (formals); formals = cdr (formals))
		3621	stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
		3622
		3623	stream_put_v (s, 0);
		3624	stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals));
		3625
		3626	compile_expr (SCHEME_A_ s, body);
		3627	}
		3628	break;
		3629
		3630	case OP_C0STREAM:/* cons-stream */
		3631	abort ();
		3632	break;
		3633	}
		3634
		3635	return;
		3636	}
		3637
		3638	pointer m = lookup (SCHEME_A_ head);
		3639
		3640	if (is_macro (m))
		3641	{
		3642	s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
		3643	SCHEME_V->code = m;
		3644	SCHEME_V->args = cons (x, NIL);
		3645	Eval_Cycle (SCHEME_A_ OP_APPLY);
		3646	x = SCHEME_V->value;
		3647	compile_expr (SCHEME_A_ s, SCHEME_V->value);
		3648	return;
		3649	}
		3650
		3651	stream_put (s, BOP_LIST_BEG);
		3652
		3653	for (; x != NIL; x = cdr (x))
		3654	compile_expr (SCHEME_A_ s, car (x));
		3655
		3656	stream_put (s, BOP_LIST_END);
		3657	return;
		3658	}
		3659
		3660	switch (type (x))
		3661	{
		3662	case T_INTEGER:
		3663	{
		3664	IVALUE iv = ivalue_unchecked (x);
		3665	iv = iv < 0 ? ((~(uint32_t)iv) << 1) \| 1 : (uint32_t)iv << 1;
		3666	stream_put_tv (s, BOP_INTEGER, iv);
		3667	}
		3668	return;
		3669
		3670	case T_SYMBOL:
		3671	if (0)
		3672	{
		3673	// no can do without more analysis
		3674	pointer m = lookup (SCHEME_A_ x);
		3675
		3676	if (is_proc (m))
		3677	{
		3678	printf ("compile proc %s %d\n", procname(m), procnum(m));
		3679	stream_put_tv (s, BOP_SYMBOL, BOP_OP + procnum (m));
		3680	}
		3681	else
		3682	stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
		3683	}
		3684
		3685	stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
		3686	return;
		3687
		3688	default:
		3689	stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
		3690	break;
		3691	}
		3692	}
		3693
		3694	ecb_cold static int
		3695	compile_closure (SCHEME_P_ pointer p)
		3696	{
		3697	stream s = stream_init ();
		3698
		3699	compile_list (SCHEME_A_ s, cdar (p));
		3700
		3701	FILE *xxd = popen ("xxd", "we");
		3702	fwrite (stream_data (s), 1, stream_size (s), xxd);
		3703	fclose (xxd);
		3704
		3705	return stream_size (s);
		3706	}
		3707
3408	#endif	3708	#endif
3409		3709
3410	/* syntax, eval, core, ... */	3710	/* syntax, eval, core, ... */
3411	ecb_hot static int	3711	ecb_hot static int
3412	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3712	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
…		…
3422	uint32_t len = compile_closure (SCHEME_A_ car (args));	3722	uint32_t len = compile_closure (SCHEME_A_ car (args));
3423	printf ("len = %d\n", len);	3723	printf ("len = %d\n", len);
3424	printf ("\n");	3724	printf ("\n");
3425	s_return (S_T);	3725	s_return (S_T);
3426	}	3726	}
		3727
		3728	case OP_DEBUG2:
		3729	return -1;
3427	#endif	3730	#endif
		3731
3428	case OP_LOAD: /* load */	3732	case OP_LOAD: /* load */
3429	if (file_interactive (SCHEME_A))	3733	if (file_interactive (SCHEME_A))
3430	{	3734	{
3431	putstr (SCHEME_A_ "Loading ");	3735	putstr (SCHEME_A_ "Loading ");
3432	putstr (SCHEME_A_ strvalue (car (args)));	3736	putstr (SCHEME_A_ strvalue (car (args)));
…		…
3462	if (file_interactive (SCHEME_A))	3766	if (file_interactive (SCHEME_A))
3463	{	3767	{
3464	SCHEME_V->envir = SCHEME_V->global_env;	3768	SCHEME_V->envir = SCHEME_V->global_env;
3465	dump_stack_reset (SCHEME_A);	3769	dump_stack_reset (SCHEME_A);
3466	putcharacter (SCHEME_A_ '\n');	3770	putcharacter (SCHEME_A_ '\n');
		3771	#if EXPERIMENT
		3772	system ("ps v $PPID");
		3773	#endif
3467	putstr (SCHEME_A_ prompt);	3774	putstr (SCHEME_A_ prompt);
3468	}	3775	}
3469		3776
3470	/* Set up another iteration of REPL */	3777	/* Set up another iteration of REPL */
3471	SCHEME_V->nesting = 0;	3778	SCHEME_V->nesting = 0;
…		…
3561	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);	3868	s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3562	SCHEME_V->args = cons (SCHEME_V->code, NIL);	3869	SCHEME_V->args = cons (SCHEME_V->code, NIL);
3563	SCHEME_V->code = SCHEME_V->value;	3870	SCHEME_V->code = SCHEME_V->value;
3564	s_goto (OP_APPLY);	3871	s_goto (OP_APPLY);
3565	}	3872	}
3566	else	3873
3567	{
3568	SCHEME_V->code = cdr (SCHEME_V->code);	3874	SCHEME_V->code = cdr (SCHEME_V->code);
3569	s_goto (OP_E1ARGS);	3875	s_goto (OP_E1ARGS);
3570	}
3571		3876
3572	case OP_E1ARGS: /* eval arguments */	3877	case OP_E1ARGS: /* eval arguments */
3573	args = cons (SCHEME_V->value, args);	3878	args = cons (SCHEME_V->value, args);
3574		3879
3575	if (is_pair (SCHEME_V->code)) /* continue */	3880	if (is_pair (SCHEME_V->code)) /* continue */
…		…
3586	SCHEME_V->args = cdr (args);	3891	SCHEME_V->args = cdr (args);
3587	s_goto (OP_APPLY);	3892	s_goto (OP_APPLY);
3588	}	3893	}
3589		3894
3590	#if USE_TRACING	3895	#if USE_TRACING
3591
3592	case OP_TRACING:	3896	case OP_TRACING:
3593	{	3897	{
3594	int tr = SCHEME_V->tracing;	3898	int tr = SCHEME_V->tracing;
3595		3899
3596	SCHEME_V->tracing = ivalue_unchecked (car (args));	3900	SCHEME_V->tracing = ivalue_unchecked (car (args));
3597	s_return (mk_integer (SCHEME_A_ tr));	3901	s_return (mk_integer (SCHEME_A_ tr));
3598	}	3902	}
3599
3600	#endif	3903	#endif
3601		3904
3602	case OP_APPLY: /* apply 'code' to 'args' */	3905	case OP_APPLY: /* apply 'code' to 'args' */
3603	#if USE_TRACING	3906	#if USE_TRACING
3604	if (SCHEME_V->tracing)	3907	if (SCHEME_V->tracing)
…		…
3658	else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */	3961	else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3659	{	3962	{
3660	ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));	3963	ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3661	s_return (args != NIL ? car (args) : NIL);	3964	s_return (args != NIL ? car (args) : NIL);
3662	}	3965	}
3663	else	3966
3664	Error_0 ("illegal function");	3967	Error_0 ("illegal function");
3665		3968
3666	case OP_DOMACRO: /* do macro */	3969	case OP_DOMACRO: /* do macro */
3667	SCHEME_V->code = SCHEME_V->value;	3970	SCHEME_V->code = SCHEME_V->value;
3668	s_goto (OP_EVAL);	3971	s_goto (OP_EVAL);
3669		3972
…		…
3790	SCHEME_V->value = SCHEME_V->code;	4093	SCHEME_V->value = SCHEME_V->code;
3791	SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);	4094	SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3792	s_goto (OP_LET1);	4095	s_goto (OP_LET1);
3793		4096
3794	case OP_LET1: /* let (calculate parameters) */	4097	case OP_LET1: /* let (calculate parameters) */
		4098	case OP_LET1REC: /* letrec (calculate parameters) */
3795	args = cons (SCHEME_V->value, args);	4099	args = cons (SCHEME_V->value, args);
3796		4100
3797	if (is_pair (SCHEME_V->code)) /* continue */	4101	if (is_pair (SCHEME_V->code)) /* continue */
3798	{	4102	{
3799	if (!is_pair (car (SCHEME_V->code)) \|\| !is_pair (cdar (SCHEME_V->code)))	4103	if (!is_pair (car (SCHEME_V->code)) \|\| !is_pair (cdar (SCHEME_V->code)))
3800	Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code));	4104	Error_1 ("Bad syntax of binding spec in let/letrec:", car (SCHEME_V->code));
3801		4105
3802	s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code));	4106	s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code));
3803	SCHEME_V->code = cadar (SCHEME_V->code);	4107	SCHEME_V->code = cadar (SCHEME_V->code);
3804	SCHEME_V->args = NIL;	4108	SCHEME_V->args = NIL;
3805	s_goto (OP_EVAL);	4109	s_goto (OP_EVAL);
3806	}	4110	}
3807	else /* end */	4111
3808	{	4112	/* end */
3809	args = reverse_in_place (SCHEME_A_ NIL, args);	4113	args = reverse_in_place (SCHEME_A_ NIL, args);
3810	SCHEME_V->code = car (args);	4114	SCHEME_V->code = car (args);
3811	SCHEME_V->args = cdr (args);	4115	SCHEME_V->args = cdr (args);
3812	s_goto (OP_LET2);	4116	s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC);
3813	}
3814		4117
3815	case OP_LET2: /* let */	4118	case OP_LET2: /* let */
3816	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);	4119	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3817		4120
3818	for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;	4121	for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
…		…
3822	if (is_symbol (car (SCHEME_V->code))) /* named let */	4125	if (is_symbol (car (SCHEME_V->code))) /* named let */
3823	{	4126	{
3824	for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))	4127	for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3825	{	4128	{
3826	if (!is_pair (x))	4129	if (!is_pair (x))
3827	Error_1 ("Bad syntax of binding in let :", x);	4130	Error_1 ("Bad syntax of binding in let:", x);
3828		4131
3829	if (!is_list (SCHEME_A_ car (x)))	4132	if (!is_list (SCHEME_A_ car (x)))
3830	Error_1 ("Bad syntax of binding in let :", car (x));	4133	Error_1 ("Bad syntax of binding in let:", car (x));
3831		4134
3832	args = cons (caar (x), args);	4135	args = cons (caar (x), args);
3833	}	4136	}
3834		4137
3835	x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),	4138	x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
…		…
3852	SCHEME_V->code = cdr (SCHEME_V->code);	4155	SCHEME_V->code = cdr (SCHEME_V->code);
3853	s_goto (OP_BEGIN);	4156	s_goto (OP_BEGIN);
3854	}	4157	}
3855		4158
3856	if (!is_pair (car (SCHEME_V->code)) \|\| !is_pair (caar (SCHEME_V->code)) \|\| !is_pair (cdaar (SCHEME_V->code)))	4159	if (!is_pair (car (SCHEME_V->code)) \|\| !is_pair (caar (SCHEME_V->code)) \|\| !is_pair (cdaar (SCHEME_V->code)))
3857	Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code));	4160	Error_1 ("Bad syntax of binding spec in let*:", car (SCHEME_V->code));
3858		4161
3859	s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));	4162	s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
3860	SCHEME_V->code = car (cdaar (SCHEME_V->code));	4163	SCHEME_V->code = car (cdaar (SCHEME_V->code));
3861	s_goto (OP_EVAL);	4164	s_goto (OP_EVAL);
3862		4165
…		…
3873	s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);	4176	s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3874	SCHEME_V->code = cadar (SCHEME_V->code);	4177	SCHEME_V->code = cadar (SCHEME_V->code);
3875	SCHEME_V->args = NIL;	4178	SCHEME_V->args = NIL;
3876	s_goto (OP_EVAL);	4179	s_goto (OP_EVAL);
3877	}	4180	}
3878	else /* end */	4181
		4182	/* end */
3879	{	4183
3880	SCHEME_V->code = args;	4184	SCHEME_V->code = args;
3881	SCHEME_V->args = NIL;	4185	SCHEME_V->args = NIL;
3882	s_goto (OP_BEGIN);	4186	s_goto (OP_BEGIN);
3883	}
3884		4187
3885	case OP_LET0REC: /* letrec */	4188	case OP_LET0REC: /* letrec */
3886	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);	4189	new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3887	SCHEME_V->args = NIL;	4190	SCHEME_V->args = NIL;
3888	SCHEME_V->value = SCHEME_V->code;	4191	SCHEME_V->value = SCHEME_V->code;
3889	SCHEME_V->code = car (SCHEME_V->code);	4192	SCHEME_V->code = car (SCHEME_V->code);
3890	s_goto (OP_LET1REC);	4193	s_goto (OP_LET1REC);
3891		4194
3892	case OP_LET1REC: /* letrec (calculate parameters) */	4195	/* OP_LET1REC handled by OP_LET1 */
3893	args = cons (SCHEME_V->value, args);
3894
3895	if (is_pair (SCHEME_V->code)) /* continue */
3896	{
3897	if (!is_pair (car (SCHEME_V->code)) \|\| !is_pair (cdar (SCHEME_V->code)))
3898	Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3899
3900	s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3901	SCHEME_V->code = cadar (SCHEME_V->code);
3902	SCHEME_V->args = NIL;
3903	s_goto (OP_EVAL);
3904	}
3905	else /* end */
3906	{
3907	args = reverse_in_place (SCHEME_A_ NIL, args);
3908	SCHEME_V->code = car (args);
3909	SCHEME_V->args = cdr (args);
3910	s_goto (OP_LET2REC);
3911	}
3912		4196
3913	case OP_LET2REC: /* letrec */	4197	case OP_LET2REC: /* letrec */
3914	for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))	4198	for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3915	new_slot_in_env (SCHEME_A_ caar (x), car (y));	4199	new_slot_in_env (SCHEME_A_ caar (x), car (y));
3916		4200
…		…
5083	case OP_RDSEXPR:	5367	case OP_RDSEXPR:
5084	switch (SCHEME_V->tok)	5368	switch (SCHEME_V->tok)
5085	{	5369	{
5086	case TOK_EOF:	5370	case TOK_EOF:
5087	s_return (S_EOF);	5371	s_return (S_EOF);
5088	/* NOTREACHED */
5089		5372
5090	case TOK_VEC:	5373	case TOK_VEC:
5091	s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);	5374	s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
5092	/* fall through */	5375	/* fall through */
5093		5376
…		…
5096		5379
5097	if (SCHEME_V->tok == TOK_RPAREN)	5380	if (SCHEME_V->tok == TOK_RPAREN)
5098	s_return (NIL);	5381	s_return (NIL);
5099	else if (SCHEME_V->tok == TOK_DOT)	5382	else if (SCHEME_V->tok == TOK_DOT)
5100	Error_0 ("syntax error: illegal dot expression");	5383	Error_0 ("syntax error: illegal dot expression");
5101	else	5384
5102	{
5103	SCHEME_V->nesting_stack[SCHEME_V->file_i]++;	5385	SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
5104	s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);	5386	s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
5105	s_goto (OP_RDSEXPR);	5387	s_goto (OP_RDSEXPR);
5106	}
5107		5388
5108	case TOK_QUOTE:	5389	case TOK_QUOTE:
5109	s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);	5390	s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
5110	SCHEME_V->tok = token (SCHEME_A);	5391	SCHEME_V->tok = token (SCHEME_A);
5111	s_goto (OP_RDSEXPR);	5392	s_goto (OP_RDSEXPR);
…		…
5117	{	5398	{
5118	s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);	5399	s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5119	SCHEME_V->tok = TOK_LPAREN;	5400	SCHEME_V->tok = TOK_LPAREN;
5120	s_goto (OP_RDSEXPR);	5401	s_goto (OP_RDSEXPR);
5121	}	5402	}
5122	else	5403
5123	s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);	5404	s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5124
5125	s_goto (OP_RDSEXPR);	5405	s_goto (OP_RDSEXPR);
5126		5406
5127	case TOK_COMMA:	5407	case TOK_COMMA:
5128	s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);	5408	s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
5129	SCHEME_V->tok = token (SCHEME_A);	5409	SCHEME_V->tok = token (SCHEME_A);
…		…
5140	case TOK_DOTATOM:	5420	case TOK_DOTATOM:
5141	SCHEME_V->strbuff[0] = '.';	5421	SCHEME_V->strbuff[0] = '.';
5142	s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));	5422	s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5143		5423
5144	case TOK_STRATOM:	5424	case TOK_STRATOM:
		5425	//TODO: haven't checked whether the garbage collector could interfere and free x
		5426	gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded
5145	x = readstrexp (SCHEME_A_ '\|');	5427	x = readstrexp (SCHEME_A_ '\|');
5146	//TODO: haven't checked whether the garbage collector could interfere
5147	s_return (mk_atom (SCHEME_A_ strvalue (x)));	5428	s_return (mk_atom (SCHEME_A_ strvalue (x)));
5148		5429
5149	case TOK_DQUOTE:	5430	case TOK_DQUOTE:
5150	x = readstrexp (SCHEME_A_ '"');	5431	x = readstrexp (SCHEME_A_ '"');
5151		5432
…		…
5159	{	5440	{
5160	pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);	5441	pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);
5161		5442
5162	if (f == NIL)	5443	if (f == NIL)
5163	Error_0 ("undefined sharp expression");	5444	Error_0 ("undefined sharp expression");
5164	else	5445
5165	{
5166	SCHEME_V->code = cons (slot_value_in_env (f), NIL);	5446	SCHEME_V->code = cons (slot_value_in_env (f), NIL);
5167	s_goto (OP_EVAL);	5447	s_goto (OP_EVAL);
5168	}
5169	}	5448	}
5170		5449
5171	case TOK_SHARP_CONST:	5450	case TOK_SHARP_CONST:
5172	if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)	5451	if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5173	Error_0 ("undefined sharp expression");	5452	Error_0 ("undefined sharp expression");
5174	else	5453
5175	s_return (x);	5454	s_return (x);
5176		5455
5177	default:	5456	default:
5178	Error_0 ("syntax error: illegal token");	5457	Error_0 ("syntax error: illegal token");
5179	}	5458	}
5180		5459
…		…
5380	break;	5659	break;
5381	}	5660	}
5382		5661
5383	if (is_pair (y))	5662	if (is_pair (y))
5384	s_return (car (y));	5663	s_return (car (y));
5385	else	5664
5386	s_return (S_F);	5665	s_return (S_F);
5387
5388		5666
5389	case OP_GET_CLOSURE: /* get-closure-code // a.k */	5667	case OP_GET_CLOSURE: /* get-closure-code // a.k */
5390	SCHEME_V->args = a;	5668	SCHEME_V->args = a;
5391		5669
5392	if (SCHEME_V->args == NIL)	5670	if (SCHEME_V->args == NIL)
5393	s_return (S_F);	5671	s_return (S_F);
5394	else if (is_closure (SCHEME_V->args))	5672	else if (is_closure (SCHEME_V->args) \|\| is_macro (SCHEME_V->args))
5395	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));	5673	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5396	else if (is_macro (SCHEME_V->args))	5674
5397	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5398	else
5399	s_return (S_F);	5675	s_return (S_F);
5400		5676
5401	case OP_CLOSUREP: /* closure? */	5677	case OP_CLOSUREP: /* closure? */
5402	/*	5678	/*
5403	* Note, macro object is also a closure.	5679	* Note, macro object is also a closure.
5404	* Therefore, (closure? <#MACRO>) ==> #t	5680	* Therefore, (closure? <#MACRO>) ==> #t
…		…
5738		6014
5739	ecb_cold int	6015	ecb_cold int
5740	scheme_init (SCHEME_P)	6016	scheme_init (SCHEME_P)
5741	{	6017	{
5742	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	6018	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5743	pointer x;
5744		6019
5745	/* this memset is not strictly correct, as we assume (intcache)	6020	/* this memset is not strictly correct, as we assume (intcache)
5746	* that memset 0 will also set pointers to 0, but memset does	6021	* that memset 0 will also set pointers to 0, but memset does
5747	* of course not guarantee that. screw such systems.	6022	* of course not guarantee that. screw such systems.
5748	*/	6023	*/
…		…
5783	SCHEME_V->envir = NIL;	6058	SCHEME_V->envir = NIL;
5784	SCHEME_V->value = NIL;	6059	SCHEME_V->value = NIL;
5785	SCHEME_V->tracing = 0;	6060	SCHEME_V->tracing = 0;
5786		6061
5787	/* init NIL */	6062	/* init NIL */
5788	set_typeflag (NIL, T_ATOM \| T_MARK);	6063	set_typeflag (NIL, T_SPECIAL \| T_ATOM);
5789	set_car (NIL, NIL);	6064	set_car (NIL, NIL);
5790	set_cdr (NIL, NIL);	6065	set_cdr (NIL, NIL);
5791	/* init T */	6066	/* init T */
5792	set_typeflag (S_T, T_ATOM \| T_MARK);	6067	set_typeflag (S_T, T_SPECIAL \| T_ATOM);
5793	set_car (S_T, S_T);	6068	set_car (S_T, S_T);
5794	set_cdr (S_T, S_T);	6069	set_cdr (S_T, S_T);
5795	/* init F */	6070	/* init F */
5796	set_typeflag (S_F, T_ATOM \| T_MARK);	6071	set_typeflag (S_F, T_SPECIAL \| T_ATOM);
5797	set_car (S_F, S_F);	6072	set_car (S_F, S_F);
5798	set_cdr (S_F, S_F);	6073	set_cdr (S_F, S_F);
5799	/* init EOF_OBJ */	6074	/* init EOF_OBJ */
5800	set_typeflag (S_EOF, T_ATOM \| T_MARK);	6075	set_typeflag (S_EOF, T_SPECIAL \| T_ATOM);
5801	set_car (S_EOF, S_EOF);	6076	set_car (S_EOF, S_EOF);
5802	set_cdr (S_EOF, S_EOF);	6077	set_cdr (S_EOF, S_EOF);
5803	/* init sink */	6078	/* init sink */
5804	set_typeflag (S_SINK, T_PAIR \| T_MARK);	6079	set_typeflag (S_SINK, T_PAIR);
5805	set_car (S_SINK, NIL);	6080	set_car (S_SINK, NIL);
5806		6081
5807	/* init c_nest */	6082	/* init c_nest */
5808	SCHEME_V->c_nest = NIL;	6083	SCHEME_V->c_nest = NIL;
5809		6084
5810	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);	6085	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5811	/* init global_env */	6086	/* init global_env */
5812	new_frame_in_env (SCHEME_A_ NIL);	6087	new_frame_in_env (SCHEME_A_ NIL);
5813	SCHEME_V->global_env = SCHEME_V->envir;	6088	SCHEME_V->global_env = SCHEME_V->envir;
5814	/* init else */	6089	/* init else */
5815	x = mk_symbol (SCHEME_A_ "else");	6090	new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), S_T);
5816	new_slot_in_env (SCHEME_A_ x, S_T);
5817		6091
5818	{	6092	{
5819	static const char *syntax_names[] = {	6093	static const char *syntax_names[] = {
5820	"lambda", "quote", "define", "if", "begin", "set!",	6094	"lambda", "quote", "define", "if", "begin", "set!",
5821	"let", "let*", "letrec", "cond", "delay", "and",	6095	"let", "let*", "letrec", "cond", "delay", "and",
…		…
5912	SCHEME_V->loadport = NIL;	6186	SCHEME_V->loadport = NIL;
5913	SCHEME_V->gc_verbose = 0;	6187	SCHEME_V->gc_verbose = 0;
5914	gc (SCHEME_A_ NIL, NIL);	6188	gc (SCHEME_A_ NIL, NIL);
5915		6189
5916	for (i = 0; i <= SCHEME_V->last_cell_seg; i++)	6190	for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5917	free (SCHEME_V->alloc_seg[i]);	6191	free (SCHEME_V->cell_seg[i]);
5918		6192
5919	#if SHOW_ERROR_LINE	6193	#if SHOW_ERROR_LINE
5920	for (i = 0; i <= SCHEME_V->file_i; i++)	6194	for (i = 0; i <= SCHEME_V->file_i; i++)
5921	{
5922	if (SCHEME_V->load_stack[i].kind & port_file)	6195	if (SCHEME_V->load_stack[i].kind & port_file)
5923	{	6196	{
5924	fname = SCHEME_V->load_stack[i].rep.stdio.filename;	6197	fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5925		6198
5926	if (fname)	6199	if (fname)
5927	free (fname);	6200	free (fname);
5928	}	6201	}
5929	}
5930	#endif	6202	#endif
5931	}	6203	}
5932		6204
5933	ecb_cold void	6205	ecb_cold void
5934	scheme_load_file (SCHEME_P_ int fin)	6206	scheme_load_file (SCHEME_P_ int fin)
…		…
6106	# endif	6378	# endif
6107	int fin;	6379	int fin;
6108	char *file_name = InitFile;	6380	char *file_name = InitFile;
6109	int retcode;	6381	int retcode;
6110	int isfile = 1;	6382	int isfile = 1;
		6383	#if EXPERIMENT
6111	system ("ps v $PPID");//D	6384	system ("ps v $PPID");
		6385	#endif
6112		6386
6113	if (argc == 2 && strcmp (argv[1], "-?") == 0)	6387	if (argc == 2 && strcmp (argv[1], "-?") == 0)
6114	{	6388	{
6115	putstr (SCHEME_A_ "Usage: tinyscheme -?\n");	6389	putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6116	putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");	6390	putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");

Diff Legend

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

Comparing cvsroot/microscheme/scheme.c (file contents): Revision 1.61 by root, Wed Dec 2 07:43:46 2015 UTC vs. Revision 1.66 by root, Mon Dec 7 18:10:57 2015 UTC

Diff Legend

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.61 by root, Wed Dec 2 07:43:46 2015 UTC vs.
Revision 1.66 by root, Mon Dec 7 18:10:57 2015 UTC