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

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

Diff Legend

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

Comparing cvsroot/microscheme/scheme.c (file contents): Revision 1.64 by root, Wed Dec 2 17:01:18 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.64 by root, Wed Dec 2 17:01:18 2015 UTC vs.
Revision 1.66 by root, Mon Dec 7 18:10:57 2015 UTC