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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.65 by root, Wed Dec 2 17:01:51 2015 UTC vs.
Revision 1.68 by root, Mon Dec 7 21:12:56 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;
…		…
328	string_value (pointer p)	329	string_value (pointer p)
329	{	330	{
330	return strvalue (p);	331	return strvalue (p);
331	}	332	}
332		333
333	#define ivalue_unchecked(p) CELL(p)->object.ivalue	334	#define ivalue_unchecked(p) (CELL(p)->object.ivalue + 0)
334	#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)	335	#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
335		336
336	#if USE_REAL	337	#if USE_REAL
337	#define rvalue_unchecked(p) CELL(p)->object.rvalue	338	#define rvalue_unchecked(p) CELL(p)->object.rvalue
338	#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)	339	#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
…		…
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
…		…
1251	if (!*pp)	1259	if (!*pp)
1252	{	1260	{
1253	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1261	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1254		1262
1255	set_typeflag (x, T_INTEGER \| T_ATOM);	1263	set_typeflag (x, T_INTEGER \| T_ATOM);
1256	setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */	1264	setimmutable (x); /* shouldn't do anything, doesn't cost anything */
1257	set_ivalue (x, n);	1265	set_ivalue (x, n);
1258		1266
1259	*pp = x;	1267	*pp = x;
1260	}	1268	}
1261		1269
…		…
1538	return mk_character (SCHEME_A_ c);	1546	return mk_character (SCHEME_A_ c);
1539	}	1547	}
1540	else	1548	else
1541	{	1549	{
1542	/* identify base by string index */	1550	/* identify base by string index */
1543	const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";	1551	const char baseidx[18] = "ffbf" "ffff" "ofdf" "ffff" "x";
1544	char base = strchr (baseidx, name);	1552	char base = strchr (baseidx, name);
1545		1553
1546	if (base)	1554	if (base && *base)
1547	return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));	1555	return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1548		1556
1549	return NIL;	1557	return NIL;
1550	}	1558	}
1551	}	1559	}
…		…
2605	}	2613	}
2606	else if (is_symbol (l))	2614	else if (is_symbol (l))
2607	p = symname (l);	2615	p = symname (l);
2608	else if (is_proc (l))	2616	else if (is_proc (l))
2609	{	2617	{
		2618	p = (char *)procname (l); // ok with r7rs display, but not r7rs write
		2619	#if 0
2610	#if USE_PRINTF	2620	#if USE_PRINTF
2611	p = SCHEME_V->strbuff;	2621	p = SCHEME_V->strbuff;
2612	snprintf (p, STRBUFFSIZE, "#<%s PROCEDURE %ld>", procname (l), procnum (l));	2622	snprintf (p, STRBUFFSIZE, " PROCEDURE %ld>", procname (l), procnum (l));
2613	#else	2623	#else
2614	p = "#<PROCEDURE>";	2624	p = "#<PROCEDURE>";
		2625	#endif
2615	#endif	2626	#endif
2616	}	2627	}
2617	else if (is_macro (l))	2628	else if (is_macro (l))
2618	p = "#<MACRO>";	2629	p = "#<MACRO>";
2619	else if (is_closure (l))	2630	else if (is_closure (l))
…		…
3338	stream_put (s, stream_data (o)[i]);	3349	stream_put (s, stream_data (o)[i]);
3339		3350
3340	stream_free (o);	3351	stream_free (o);
3341	}	3352	}
3342		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
3343	// calculates a (preferably small) integer that makes it possible to find	3367	// calculates a (preferably small) integer that makes it possible to find
3344	// the symbol again. if pointers were offsets into a memory area... until	3368	// 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	3369	// then, we return segment number in the low bits, and offset in the high
3346	// bits.	3370	// bits.
3347	// also, this function must never return 0.	3371	// also, this function must never return 0.
3348	ecb_cold static uint32_t	3372	ecb_cold static uint32_t
3349	symbol_id (SCHEME_P_ pointer sym)	3373	symbol_id (SCHEME_P_ pointer sym)
3350	{	3374	{
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);	3375	return cell_id (SCHEME_A_ sym);
3365	}	3376	}
3366		3377
3367	enum byteop	3378	enum byteop
3368	{	3379	{
3369	BOP_NIL,	3380	BOP_NIL,
3370	BOP_SYNTAX,
3371	BOP_INTEGER,	3381	BOP_INTEGER,
3372	BOP_SYMBOL,	3382	BOP_SYMBOL,
		3383	BOP_DATUM,
3373	BOP_LIST_BEG,	3384	BOP_LIST_BEG,
3374	BOP_LIST_END,	3385	BOP_LIST_END,
3375	BOP_BIFT, // branch if true	3386	BOP_IF,
3376	BOP_BIFF, // branch if false	3387	BOP_AND,
3377	BOP_BIFNE, // branch if not eqv?	3388	BOP_OR,
3378	BOP_BRA, // "short" branch	3389	BOP_CASE,
3379	BOP_JMP, // "long" jump	3390	BOP_COND,
3380	BOP_DATUM,
3381	BOP_LET,	3391	BOP_LET,
3382	BOP_LETAST,	3392	BOP_LETAST,
3383	BOP_LETREC,	3393	BOP_LETREC,
3384	BOP_DEFINE,	3394	BOP_DEFINE,
3385	BOP_MACRO,	3395	BOP_MACRO,
3386	BOP_SET,	3396	BOP_SET,
3387	BOP_BEGIN,	3397	BOP_BEGIN,
3388	BOP_LAMBDA,	3398	BOP_LAMBDA,
		3399	BOP_DELAY,
		3400	BOP_OP,
3389	};	3401	};
3390		3402
3391	ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);	3403	ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
3392		3404
3393	ecb_cold static void	3405	ecb_cold static void
3394	compile_list (SCHEME_P_ stream s, pointer x)	3406	compile_list (SCHEME_P_ stream s, pointer x)
3395	{	3407	{
		3408	// TODO: improper list
		3409
3396	for (; x != NIL; x = cdr (x))	3410	for (; x != NIL; x = cdr (x))
		3411	{
		3412	stream t = stream_init ();
3397	compile_expr (SCHEME_A_ s, car (x));	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);
3398	}	3419	}
3399		3420
3400	static void	3421	static void
3401	compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)	3422	compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
3402	{	3423	{
3403	//TODO: borked
3404	stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);	3424	stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
3405		3425
3406	stream_put (s, BOP_BIFF);	3426	stream_put (s, BOP_IF);
3407	compile_expr (SCHEME_A_ s, cond);	3427	compile_expr (SCHEME_A_ s, cond);
3408	stream_put_v (s, stream_size (sift));	3428	stream_put_v (s, stream_size (sift));
3409	stream_put_stream (s, sift);	3429	stream_put_stream (s, sift);
3410		3430	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	}	3431	}
3418		3432
3419	typedef uint32_t stream_fixup;	3433	typedef uint32_t stream_fixup;
3420		3434
3421	static stream_fixup	3435	static stream_fixup
…		…
3437	}	3451	}
3438		3452
3439	static void	3453	static void
3440	compile_and_or (SCHEME_P_ stream s, int and, pointer x)	3454	compile_and_or (SCHEME_P_ stream s, int and, pointer x)
3441	{	3455	{
3442	if (cdr (x) == NIL)	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	{
3443	compile_expr (SCHEME_A_ s, car (x));	3470	compile_expr (SCHEME_A_ s, caar (x));
3444	else	3471
		3472	for (;;)
3445	{	3473	{
3446	stream_put (s, and ? BOP_BIFF : BOP_BIFT);	3474	x = cdr (x);
		3475
		3476	if (x == NIL)
		3477	break;
		3478
3447	compile_expr (SCHEME_A_ s, car (x));	3479	compile_expr (SCHEME_A_ s, caar (x));
3448	stream_fixup end = stream_put_fixup (s);	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	}
3449		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	{
3450	compile_and_or (SCHEME_A_ s, and, cdr (x));	3493	compile_expr (SCHEME_A_ s, caar (x));
		3494	stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
3451	stream_fix_fixup (s, end, stream_size (s));	3495	stream_put_v (s, stream_size (t));
		3496	stream_put_stream (s, t);
3452	}	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;
3453	}	3511	}
3454		3512
3455	ecb_cold static void	3513	ecb_cold static void
3456	compile_expr (SCHEME_P_ stream s, pointer x)	3514	compile_expr (SCHEME_P_ stream s, pointer x)
3457	{	3515	{
…		…
3465	{	3523	{
3466	pointer head = car (x);	3524	pointer head = car (x);
3467		3525
3468	if (is_syntax (head))	3526	if (is_syntax (head))
3469	{	3527	{
		3528	int syn = syntaxnum (head);
3470	x = cdr (x);	3529	x = cdr (x);
3471		3530
3472	switch (syntaxnum (head))	3531	switch (syntaxnum (head))
3473	{	3532	{
3474	case OP_IF0: /* if */	3533	case OP_IF0: /* if */
		3534	stream_put_v (s, BOP_IF);
3475	compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));	3535	compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
3476	break;	3536	break;
3477		3537
3478	case OP_OR0: /* or */	3538	case OP_OR0: /* or */
		3539	stream_put_v (s, BOP_OR);
3479	compile_and_or (SCHEME_A_ s, 0, x);	3540	compile_and_or (SCHEME_A_ s, 0, x);
3480	break;	3541	break;
3481		3542
3482	case OP_AND0: /* and */	3543	case OP_AND0: /* and */
		3544	stream_put_v (s, BOP_AND);
3483	compile_and_or (SCHEME_A_ s, 1, x);	3545	compile_and_or (SCHEME_A_ s, 1, x);
3484	break;	3546	break;
3485		3547
3486	case OP_CASE0: /* case */	3548	case OP_CASE0: /* case */
3487	abort ();	3549	stream_put_v (s, BOP_CASE);
		3550	compile_case (SCHEME_A_ s, x);
3488	break;	3551	break;
3489		3552
3490	case OP_COND0: /* cond */	3553	case OP_COND0: /* cond */
3491	abort ();	3554	stream_put_v (s, BOP_COND);
		3555	compile_cond (SCHEME_A_ s, x);
3492	break;	3556	break;
3493		3557
3494	case OP_LET0: /* let */	3558	case OP_LET0: /* let */
3495	case OP_LET0AST: /* let* */	3559	case OP_LET0AST: /* let* */
3496	case OP_LET0REC: /* letrec */	3560	case OP_LET0REC: /* letrec */
3497	switch (syntaxnum (head))	3561	switch (syn)
3498	{	3562	{
3499	case OP_LET0: stream_put (s, BOP_LET ); break;	3563	case OP_LET0: stream_put (s, BOP_LET ); break;
3500	case OP_LET0AST: stream_put (s, BOP_LETAST); break;	3564	case OP_LET0AST: stream_put (s, BOP_LETAST); break;
3501	case OP_LET0REC: stream_put (s, BOP_LETREC); break;	3565	case OP_LET0REC: stream_put (s, BOP_LETREC); break;
3502	}	3566	}
…		…
3541	case OP_BEGIN: /* begin */	3605	case OP_BEGIN: /* begin */
3542	stream_put (s, BOP_BEGIN);	3606	stream_put (s, BOP_BEGIN);
3543	compile_list (SCHEME_A_ s, x);	3607	compile_list (SCHEME_A_ s, x);
3544	return;	3608	return;
3545		3609
3546	case OP_DELAY: /* delay */
3547	abort ();
3548	break;
3549
3550	case OP_QUOTE: /* quote */	3610	case OP_QUOTE: /* quote */
3551	stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));	3611	stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3552	break;	3612	break;
3553		3613
		3614	case OP_DELAY: /* delay */
3554	case OP_LAMBDA: /* lambda */	3615	case OP_LAMBDA: /* lambda */
3555	{	3616	{
3556	pointer formals = car (x);	3617	pointer formals = car (x);
3557	pointer body = cadr (x);	3618	pointer body = cadr (x);
3558		3619
3559	stream_put (s, BOP_LAMBDA);	3620	stream_put (s, syn == OP_LAMBDA ? BOP_LAMBDA : BOP_DELAY);
3560		3621
3561	for (; is_pair (formals); formals = cdr (formals))	3622	for (; is_pair (formals); formals = cdr (formals))
3562	stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));	3623	stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
3563		3624
3564	stream_put_v (s, 0);	3625	stream_put_v (s, 0);
…		…
3574	}	3635	}
3575		3636
3576	return;	3637	return;
3577	}	3638	}
3578		3639
3579	pointer m = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, head, 1);	3640	pointer m = lookup (SCHEME_A_ head);
3580		3641
3581	if (m != NIL)	3642	if (is_macro (m))
3582	{	3643	{
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);	3644	s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
3588	SCHEME_V->code = m;	3645	SCHEME_V->code = m;
3589	SCHEME_V->args = cons (x, NIL);	3646	SCHEME_V->args = cons (x, NIL);
3590	Eval_Cycle (SCHEME_A_ OP_APPLY);	3647	Eval_Cycle (SCHEME_A_ OP_APPLY);
3591	x = SCHEME_V->value;	3648	x = SCHEME_V->value;
3592	compile_expr (SCHEME_A_ s, SCHEME_V->value);	3649	compile_expr (SCHEME_A_ s, SCHEME_V->value);
3593	return;	3650	return;
3594	}
3595	}	3651	}
		3652
		3653	stream_put (s, BOP_LIST_BEG);
		3654
		3655	for (; x != NIL; x = cdr (x))
		3656	compile_expr (SCHEME_A_ s, car (x));
		3657
		3658	stream_put (s, BOP_LIST_END);
		3659	return;
3596	}	3660	}
3597		3661
3598	switch (type (x))	3662	switch (type (x))
3599	{	3663	{
3600	case T_INTEGER:	3664	case T_INTEGER:
3601	{	3665	{
3602	IVALUE iv = ivalue_unchecked (x);	3666	IVALUE iv = ivalue_unchecked (x);
3603	iv = iv < 0 ? ((uint32_t)-iv << 1) \| 1 : (uint32_t)iv << 1;	3667	iv = iv < 0 ? ((~(uint32_t)iv) << 1) \| 1 : (uint32_t)iv << 1;
3604	stream_put_tv (s, BOP_INTEGER, iv);	3668	stream_put_tv (s, BOP_INTEGER, iv);
3605	}	3669	}
3606	return;	3670	return;
3607		3671
3608	case T_SYMBOL:	3672	case T_SYMBOL:
		3673	if (0)
		3674	{
		3675	// no can do without more analysis
		3676	pointer m = lookup (SCHEME_A_ x);
		3677
		3678	if (is_proc (m))
		3679	{
		3680	printf ("compile proc %s %d\n", procname(m), procnum(m));
		3681	stream_put_tv (s, BOP_SYMBOL, BOP_OP + procnum (m));
		3682	}
		3683	else
		3684	stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
		3685	}
		3686
3609	stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));	3687	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;	3688	return;
3620		3689
3621	default:	3690	default:
3622	stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));	3691	stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3623	break;	3692	break;
…		…
5530	s_return (S_T);	5599	s_return (S_T);
5531	}	5600	}
5532		5601
5533	case OP_PVECFROM:	5602	case OP_PVECFROM:
5534	{	5603	{
5535	int i = ivalue_unchecked (cdr (args));	5604	IVALUE i = ivalue_unchecked (cdr (args));
5536	pointer vec = car (args);	5605	pointer vec = car (args);
5537	int len = veclength (vec);	5606	uint32_t len = veclength (vec);
5538		5607
5539	if (i == len)	5608	if (i == len)
5540	{	5609	{
5541	putcharacter (SCHEME_A_ ')');	5610	putcharacter (SCHEME_A_ ')');
5542	s_return (S_T);	5611	s_return (S_T);
5543	}	5612	}
5544	else	5613	else
5545	{	5614	{
5546	pointer elem = vector_get (vec, i);	5615	pointer elem = vector_get (vec, i);
5547		5616
5548	ivalue_unchecked (cdr (args)) = i + 1;	5617	set_cdr (args, mk_integer (SCHEME_A_ i + 1));
5549	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);	5618	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5550	SCHEME_V->args = elem;	5619	SCHEME_V->args = elem;
5551		5620
5552	if (i > 0)	5621	if (i > 0)
5553	putcharacter (SCHEME_A_ ' ');	5622	putcharacter (SCHEME_A_ ' ');
…		…
5853	static pointer	5922	static pointer
5854	mk_proc (SCHEME_P_ enum scheme_opcodes op)	5923	mk_proc (SCHEME_P_ enum scheme_opcodes op)
5855	{	5924	{
5856	pointer y = get_cell (SCHEME_A_ NIL, NIL);	5925	pointer y = get_cell (SCHEME_A_ NIL, NIL);
5857	set_typeflag (y, (T_PROC \| T_ATOM));	5926	set_typeflag (y, (T_PROC \| T_ATOM));
5858	ivalue_unchecked (y) = op;	5927	set_ivalue (y, op);
5859	return y;	5928	return y;
5860	}	5929	}
5861		5930
5862	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */	5931	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5863	ecb_hot static int	5932	ecb_hot static int
…		…
5947		6016
5948	ecb_cold int	6017	ecb_cold int
5949	scheme_init (SCHEME_P)	6018	scheme_init (SCHEME_P)
5950	{	6019	{
5951	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	6020	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5952	pointer x;
5953		6021
5954	/* this memset is not strictly correct, as we assume (intcache)	6022	/* this memset is not strictly correct, as we assume (intcache)
5955	* that memset 0 will also set pointers to 0, but memset does	6023	* that memset 0 will also set pointers to 0, but memset does
5956	* of course not guarantee that. screw such systems.	6024	* of course not guarantee that. screw such systems.
5957	*/	6025	*/
…		…
5992	SCHEME_V->envir = NIL;	6060	SCHEME_V->envir = NIL;
5993	SCHEME_V->value = NIL;	6061	SCHEME_V->value = NIL;
5994	SCHEME_V->tracing = 0;	6062	SCHEME_V->tracing = 0;
5995		6063
5996	/* init NIL */	6064	/* init NIL */
5997	set_typeflag (NIL, T_ATOM \| T_MARK);	6065	set_typeflag (NIL, T_SPECIAL \| T_ATOM);
5998	set_car (NIL, NIL);	6066	set_car (NIL, NIL);
5999	set_cdr (NIL, NIL);	6067	set_cdr (NIL, NIL);
6000	/* init T */	6068	/* init T */
6001	set_typeflag (S_T, T_ATOM \| T_MARK);	6069	set_typeflag (S_T, T_SPECIAL \| T_ATOM);
6002	set_car (S_T, S_T);	6070	set_car (S_T, S_T);
6003	set_cdr (S_T, S_T);	6071	set_cdr (S_T, S_T);
6004	/* init F */	6072	/* init F */
6005	set_typeflag (S_F, T_ATOM \| T_MARK);	6073	set_typeflag (S_F, T_SPECIAL \| T_ATOM);
6006	set_car (S_F, S_F);	6074	set_car (S_F, S_F);
6007	set_cdr (S_F, S_F);	6075	set_cdr (S_F, S_F);
6008	/* init EOF_OBJ */	6076	/* init EOF_OBJ */
6009	set_typeflag (S_EOF, T_ATOM \| T_MARK);	6077	set_typeflag (S_EOF, T_SPECIAL \| T_ATOM);
6010	set_car (S_EOF, S_EOF);	6078	set_car (S_EOF, S_EOF);
6011	set_cdr (S_EOF, S_EOF);	6079	set_cdr (S_EOF, S_EOF);
6012	/* init sink */	6080	/* init sink */
6013	set_typeflag (S_SINK, T_PAIR \| T_MARK);	6081	set_typeflag (S_SINK, T_PAIR);
6014	set_car (S_SINK, NIL);	6082	set_car (S_SINK, NIL);
6015		6083
6016	/* init c_nest */	6084	/* init c_nest */
6017	SCHEME_V->c_nest = NIL;	6085	SCHEME_V->c_nest = NIL;
6018		6086
6019	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);	6087	SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
6020	/* init global_env */	6088	/* init global_env */
6021	new_frame_in_env (SCHEME_A_ NIL);	6089	new_frame_in_env (SCHEME_A_ NIL);
6022	SCHEME_V->global_env = SCHEME_V->envir;	6090	SCHEME_V->global_env = SCHEME_V->envir;
6023	/* init else */	6091	/* init else */
6024	x = mk_symbol (SCHEME_A_ "else");	6092	new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), S_T);
6025	new_slot_in_env (SCHEME_A_ x, S_T);
6026		6093
6027	{	6094	{
6028	static const char *syntax_names[] = {	6095	static const char *syntax_names[] = {
6029	"lambda", "quote", "define", "if", "begin", "set!",	6096	"lambda", "quote", "define", "if", "begin", "set!",
6030	"let", "let*", "letrec", "cond", "delay", "and",	6097	"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.65 by root, Wed Dec 2 17:01:51 2015 UTC vs. Revision 1.68 by root, Mon Dec 7 21:12:56 2015 UTC

Diff Legend

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.65 by root, Wed Dec 2 17:01:51 2015 UTC vs.
Revision 1.68 by root, Mon Dec 7 21:12:56 2015 UTC