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

Comparing microscheme/scheme.c (file contents):
Revision 1.65 by root, Wed Dec 2 17:01:51 2015 UTC vs.
Revision 1.66 by root, Mon Dec 7 18:10:57 2015 UTC

…		…
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;
…		…
510		511
511	#define is_atom(p) (typeflag (p) & T_ATOM)	512	#define is_atom(p) (typeflag (p) & T_ATOM)
512	#define setatom(p) set_typeflag ((p), typeflag (p) \| T_ATOM)	513	#define setatom(p) set_typeflag ((p), typeflag (p) \| T_ATOM)
513	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)	514	#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
514		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
515	#define is_mark(p) (typeflag (p) & T_MARK)	521	#define is_mark(p) (typeflag (p) & T_MARK)
516	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)	522	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)
517	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	523	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
		524	#endif
518		525
519	INTERFACE int	526	INTERFACE int
520	is_immutable (pointer p)	527	is_immutable (pointer p)
521	{	528	{
522	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	529	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
…		…
928	last = newp + segsize - 1;	935	last = newp + segsize - 1;
929		936
930	for (p = newp; p <= last; p++)	937	for (p = newp; p <= last; p++)
931	{	938	{
932	pointer cp = POINTER (p);	939	pointer cp = POINTER (p);
		940	clrmark (cp);
933	set_typeflag (cp, T_PAIR);	941	set_typeflag (cp, T_PAIR);
934	set_car (cp, NIL);	942	set_car (cp, NIL);
935	set_cdr (cp, POINTER (p + 1));	943	set_cdr (cp, POINTER (p + 1));
936	}	944	}
937		945
…		…
3338	stream_put (s, stream_data (o)[i]);	3346	stream_put (s, stream_data (o)[i]);
3339		3347
3340	stream_free (o);	3348	stream_free (o);
3341	}	3349	}
3342		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
3343	// calculates a (preferably small) integer that makes it possible to find	3364	// calculates a (preferably small) integer that makes it possible to find
3344	// the symbol again. if pointers were offsets into a memory area... until	3365	// the symbol again. if pointers were offsets into a memory area... until
3345	// then, we return segment number in the low bits, and offset in the high	3366	// then, we return segment number in the low bits, and offset in the high
3346	// bits.	3367	// bits.
3347	// also, this function must never return 0.	3368	// also, this function must never return 0.
3348	ecb_cold static uint32_t	3369	ecb_cold static uint32_t
3349	symbol_id (SCHEME_P_ pointer sym)	3370	symbol_id (SCHEME_P_ pointer sym)
3350	{	3371	{
3351	struct cell *p = CELL (sym);
3352	int i;
3353
3354	for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3355	if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3356	return i \| ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3357
3358	abort ();
3359	}
3360
3361	ecb_cold static uint32_t
3362	cell_id (SCHEME_P_ pointer p)
3363	{
3364	return symbol_id (SCHEME_A_ p);	3372	return cell_id (SCHEME_A_ sym);
3365	}	3373	}
3366		3374
3367	enum byteop	3375	enum byteop
3368	{	3376	{
3369	BOP_NIL,	3377	BOP_NIL,
3370	BOP_SYNTAX,
3371	BOP_INTEGER,	3378	BOP_INTEGER,
3372	BOP_SYMBOL,	3379	BOP_SYMBOL,
		3380	BOP_DATUM,
3373	BOP_LIST_BEG,	3381	BOP_LIST_BEG,
3374	BOP_LIST_END,	3382	BOP_LIST_END,
3375	BOP_BIFT, // branch if true	3383	BOP_IF,
3376	BOP_BIFF, // branch if false	3384	BOP_AND,
3377	BOP_BIFNE, // branch if not eqv?	3385	BOP_OR,
3378	BOP_BRA, // "short" branch	3386	BOP_CASE,
3379	BOP_JMP, // "long" jump	3387	BOP_COND,
3380	BOP_DATUM,
3381	BOP_LET,	3388	BOP_LET,
3382	BOP_LETAST,	3389	BOP_LETAST,
3383	BOP_LETREC,	3390	BOP_LETREC,
3384	BOP_DEFINE,	3391	BOP_DEFINE,
3385	BOP_MACRO,	3392	BOP_MACRO,
3386	BOP_SET,	3393	BOP_SET,
3387	BOP_BEGIN,	3394	BOP_BEGIN,
3388	BOP_LAMBDA,	3395	BOP_LAMBDA,
		3396	BOP_OP,
3389	};	3397	};
3390		3398
3391	ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);	3399	ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
3392		3400
3393	ecb_cold static void	3401	ecb_cold static void
3394	compile_list (SCHEME_P_ stream s, pointer x)	3402	compile_list (SCHEME_P_ stream s, pointer x)
3395	{	3403	{
		3404	// TODO: improper list
		3405
3396	for (; x != NIL; x = cdr (x))	3406	for (; x != NIL; x = cdr (x))
		3407	{
		3408	stream t = stream_init ();
3397	compile_expr (SCHEME_A_ s, car (x));	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);
3398	}	3415	}
3399		3416
3400	static void	3417	static void
3401	compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)	3418	compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
3402	{	3419	{
3403	//TODO: borked
3404	stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);	3420	stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
3405		3421
3406	stream_put (s, BOP_BIFF);	3422	stream_put (s, BOP_IF);
3407	compile_expr (SCHEME_A_ s, cond);	3423	compile_expr (SCHEME_A_ s, cond);
3408	stream_put_v (s, stream_size (sift));	3424	stream_put_v (s, stream_size (sift));
3409	stream_put_stream (s, sift);	3425	stream_put_stream (s, sift);
3410		3426	compile_expr (SCHEME_A_ s, iff);
3411	if (iff != NIL)
3412	{
3413	stream siff = stream_init (); compile_expr (SCHEME_A_ siff, iff);
3414	stream_put_tv (s, BOP_BRA, stream_size (siff));
3415	stream_put_stream (s, siff);
3416	}
3417	}	3427	}
3418		3428
3419	typedef uint32_t stream_fixup;	3429	typedef uint32_t stream_fixup;
3420		3430
3421	static stream_fixup	3431	static stream_fixup
…		…
3437	}	3447	}
3438		3448
3439	static void	3449	static void
3440	compile_and_or (SCHEME_P_ stream s, int and, pointer x)	3450	compile_and_or (SCHEME_P_ stream s, int and, pointer x)
3441	{	3451	{
3442	if (cdr (x) == NIL)	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	{
3443	compile_expr (SCHEME_A_ s, car (x));	3466	compile_expr (SCHEME_A_ s, caar (x));
3444	else	3467
		3468	for (;;)
3445	{	3469	{
3446	stream_put (s, and ? BOP_BIFF : BOP_BIFT);	3470	x = cdr (x);
		3471
		3472	if (x == NIL)
		3473	break;
		3474
3447	compile_expr (SCHEME_A_ s, car (x));	3475	compile_expr (SCHEME_A_ s, caar (x));
3448	stream_fixup end = stream_put_fixup (s);	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	}
3449		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	{
3450	compile_and_or (SCHEME_A_ s, and, cdr (x));	3489	compile_expr (SCHEME_A_ s, caar (x));
		3490	stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
3451	stream_fix_fixup (s, end, stream_size (s));	3491	stream_put_v (s, stream_size (t));
		3492	stream_put_stream (s, t);
3452	}	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;
3453	}	3507	}
3454		3508
3455	ecb_cold static void	3509	ecb_cold static void
3456	compile_expr (SCHEME_P_ stream s, pointer x)	3510	compile_expr (SCHEME_P_ stream s, pointer x)
3457	{	3511	{
…		…
3470	x = cdr (x);	3524	x = cdr (x);
3471		3525
3472	switch (syntaxnum (head))	3526	switch (syntaxnum (head))
3473	{	3527	{
3474	case OP_IF0: /* if */	3528	case OP_IF0: /* if */
		3529	stream_put_v (s, BOP_IF);
3475	compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));	3530	compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
3476	break;	3531	break;
3477		3532
3478	case OP_OR0: /* or */	3533	case OP_OR0: /* or */
		3534	stream_put_v (s, BOP_OR);
3479	compile_and_or (SCHEME_A_ s, 0, x);	3535	compile_and_or (SCHEME_A_ s, 0, x);
3480	break;	3536	break;
3481		3537
3482	case OP_AND0: /* and */	3538	case OP_AND0: /* and */
		3539	stream_put_v (s, BOP_AND);
3483	compile_and_or (SCHEME_A_ s, 1, x);	3540	compile_and_or (SCHEME_A_ s, 1, x);
3484	break;	3541	break;
3485		3542
3486	case OP_CASE0: /* case */	3543	case OP_CASE0: /* case */
3487	abort ();	3544	stream_put_v (s, BOP_CASE);
		3545	compile_case (SCHEME_A_ s, x);
3488	break;	3546	break;
3489		3547
3490	case OP_COND0: /* cond */	3548	case OP_COND0: /* cond */
3491	abort ();	3549	stream_put_v (s, BOP_COND);
		3550	compile_cond (SCHEME_A_ s, x);
3492	break;	3551	break;
3493		3552
3494	case OP_LET0: /* let */	3553	case OP_LET0: /* let */
3495	case OP_LET0AST: /* let* */	3554	case OP_LET0AST: /* let* */
3496	case OP_LET0REC: /* letrec */	3555	case OP_LET0REC: /* letrec */
…		…
3574	}	3633	}
3575		3634
3576	return;	3635	return;
3577	}	3636	}
3578		3637
3579	pointer m = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, head, 1);	3638	pointer m = lookup (SCHEME_A_ head);
3580		3639
3581	if (m != NIL)	3640	if (is_macro (m))
3582	{	3641	{
3583	m = slot_value_in_env (m);
3584
3585	if (is_macro (m))
3586	{
3587	s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);	3642	s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
3588	SCHEME_V->code = m;	3643	SCHEME_V->code = m;
3589	SCHEME_V->args = cons (x, NIL);	3644	SCHEME_V->args = cons (x, NIL);
3590	Eval_Cycle (SCHEME_A_ OP_APPLY);	3645	Eval_Cycle (SCHEME_A_ OP_APPLY);
3591	x = SCHEME_V->value;	3646	x = SCHEME_V->value;
3592	compile_expr (SCHEME_A_ s, SCHEME_V->value);	3647	compile_expr (SCHEME_A_ s, SCHEME_V->value);
3593	return;	3648	return;
3594	}
3595	}	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;
3596	}	3658	}
3597		3659
3598	switch (type (x))	3660	switch (type (x))
3599	{	3661	{
3600	case T_INTEGER:	3662	case T_INTEGER:
3601	{	3663	{
3602	IVALUE iv = ivalue_unchecked (x);	3664	IVALUE iv = ivalue_unchecked (x);
3603	iv = iv < 0 ? ((uint32_t)-iv << 1) \| 1 : (uint32_t)iv << 1;	3665	iv = iv < 0 ? ((~(uint32_t)iv) << 1) \| 1 : (uint32_t)iv << 1;
3604	stream_put_tv (s, BOP_INTEGER, iv);	3666	stream_put_tv (s, BOP_INTEGER, iv);
3605	}	3667	}
3606	return;	3668	return;
3607		3669
3608	case T_SYMBOL:	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
3609	stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));	3685	stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3610	return;
3611
3612	case T_PAIR:
3613	stream_put (s, BOP_LIST_BEG);
3614
3615	for (; x != NIL; x = cdr (x))
3616	compile_expr (SCHEME_A_ s, car (x));
3617
3618	stream_put (s, BOP_LIST_END);
3619	return;	3686	return;
3620		3687
3621	default:	3688	default:
3622	stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));	3689	stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3623	break;	3690	break;
…		…
5947		6014
5948	ecb_cold int	6015	ecb_cold int
5949	scheme_init (SCHEME_P)	6016	scheme_init (SCHEME_P)
5950	{	6017	{
5951	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	6018	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5952	pointer x;
5953		6019
5954	/* this memset is not strictly correct, as we assume (intcache)	6020	/* this memset is not strictly correct, as we assume (intcache)
5955	* 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
5956	* of course not guarantee that. screw such systems.	6022	* of course not guarantee that. screw such systems.
5957	*/	6023	*/
…		…
5992	SCHEME_V->envir = NIL;	6058	SCHEME_V->envir = NIL;
5993	SCHEME_V->value = NIL;	6059	SCHEME_V->value = NIL;
5994	SCHEME_V->tracing = 0;	6060	SCHEME_V->tracing = 0;
5995		6061
5996	/* init NIL */	6062	/* init NIL */
5997	set_typeflag (NIL, T_ATOM \| T_MARK);	6063	set_typeflag (NIL, T_SPECIAL \| T_ATOM);
5998	set_car (NIL, NIL);	6064	set_car (NIL, NIL);
5999	set_cdr (NIL, NIL);	6065	set_cdr (NIL, NIL);
6000	/* init T */	6066	/* init T */
6001	set_typeflag (S_T, T_ATOM \| T_MARK);	6067	set_typeflag (S_T, T_SPECIAL \| T_ATOM);
6002	set_car (S_T, S_T);	6068	set_car (S_T, S_T);
6003	set_cdr (S_T, S_T);	6069	set_cdr (S_T, S_T);
6004	/* init F */	6070	/* init F */
6005	set_typeflag (S_F, T_ATOM \| T_MARK);	6071	set_typeflag (S_F, T_SPECIAL \| T_ATOM);
6006	set_car (S_F, S_F);	6072	set_car (S_F, S_F);
6007	set_cdr (S_F, S_F);	6073	set_cdr (S_F, S_F);
6008	/* init EOF_OBJ */	6074	/* init EOF_OBJ */
6009	set_typeflag (S_EOF, T_ATOM \| T_MARK);	6075	set_typeflag (S_EOF, T_SPECIAL \| T_ATOM);
6010	set_car (S_EOF, S_EOF);	6076	set_car (S_EOF, S_EOF);
6011	set_cdr (S_EOF, S_EOF);	6077	set_cdr (S_EOF, S_EOF);
6012	/* init sink */	6078	/* init sink */
6013	set_typeflag (S_SINK, T_PAIR \| T_MARK);	6079	set_typeflag (S_SINK, T_PAIR);
6014	set_car (S_SINK, NIL);	6080	set_car (S_SINK, NIL);
6015		6081
6016	/* init c_nest */	6082	/* init c_nest */
6017	SCHEME_V->c_nest = NIL;	6083	SCHEME_V->c_nest = NIL;
6018		6084
6019	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);	6085	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
6020	/* init global_env */	6086	/* init global_env */
6021	new_frame_in_env (SCHEME_A_ NIL);	6087	new_frame_in_env (SCHEME_A_ NIL);
6022	SCHEME_V->global_env = SCHEME_V->envir;	6088	SCHEME_V->global_env = SCHEME_V->envir;
6023	/* init else */	6089	/* init else */
6024	x = mk_symbol (SCHEME_A_ "else");	6090	new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), S_T);
6025	new_slot_in_env (SCHEME_A_ x, S_T);
6026		6091
6027	{	6092	{
6028	static const char *syntax_names[] = {	6093	static const char *syntax_names[] = {
6029	"lambda", "quote", "define", "if", "begin", "set!",	6094	"lambda", "quote", "define", "if", "begin", "set!",
6030	"let", "let*", "letrec", "cond", "delay", "and",	6095	"let", "let*", "letrec", "cond", "delay", "and",

Diff Legend

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

Comparing microscheme/scheme.c (file contents): Revision 1.65 by root, Wed Dec 2 17:01:51 2015 UTC vs. Revision 1.66 by root, Mon Dec 7 18:10:57 2015 UTC

Diff Legend

Comparing microscheme/scheme.c (file contents):
Revision 1.65 by root, Wed Dec 2 17:01:51 2015 UTC vs.
Revision 1.66 by root, Mon Dec 7 18:10:57 2015 UTC