ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/cvsroot/microscheme/scheme.c

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.16 by root, Thu Nov 26 10:02:58 2015 UTC vs.
Revision 1.25 by root, Fri Nov 27 04:37:26 2015 UTC

…		…
28	#endif	28	#endif
29	#if USE_MATH	29	#if USE_MATH
30	# include <math.h>	30	# include <math.h>
31	#endif	31	#endif
32		32
		33	#include "ecb.h"
		34
33	#include <sys/types.h>	35	#include <sys/types.h>
34	#include <sys/stat.h>	36	#include <sys/stat.h>
35	#include <fcntl.h>	37	#include <fcntl.h>
36		38
37	#include <string.h>	39	#include <string.h>
…		…
65	#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?	67	#define S_T (&SCHEME_V->xT) //TODO: magic ptr value?
66	#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?	68	#define S_F (&SCHEME_V->xF) //TODO: magic ptr value?
67	#define S_SINK (&SCHEME_V->xsink)	69	#define S_SINK (&SCHEME_V->xsink)
68	#define S_EOF (&SCHEME_V->xEOF_OBJ)	70	#define S_EOF (&SCHEME_V->xEOF_OBJ)
69		71
70	/* should use libecb */
71	#if __GNUC__ >= 4
72	# define ecb_expect(expr,value) __builtin_expect ((expr),(value))
73	# define ecb_expect_false(expr) ecb_expect (!!(expr), 0)
74	# define ecb_expect_true(expr) ecb_expect (!!(expr), 1)
75	#else
76	# define ecb_expect_false(expr) !!(expr)
77	# define ecb_expect_true(expr) !!(expr)
78	#endif
79
80	#if !USE_MULTIPLICITY	72	#if !USE_MULTIPLICITY
81	static scheme sc;	73	static scheme sc;
82	#endif	74	#endif
83		75
84	static void	76	static void
…		…
153		145
154	#define toupper(c) xtoupper (c)	146	#define toupper(c) xtoupper (c)
155	#define tolower(c) xtolower (c)	147	#define tolower(c) xtolower (c)
156	#define isdigit(c) xisdigit (c)	148	#define isdigit(c) xisdigit (c)
157		149
158	#if USE_STRLWR	150	#if USE_IGNORECASE
159	static const char *	151	static const char *
160	strlwr (char *s)	152	xstrlwr (char *s)
161	{	153	{
162	const char *p = s;	154	const char *p = s;
163		155
164	while (*s)	156	while (*s)
165	{	157	{
…		…
167	s++;	159	s++;
168	}	160	}
169		161
170	return p;	162	return p;
171	}	163	}
172	#endif
173		164
		165	#define stricmp(a,b) strcasecmp (a, b)
		166	#define strlwr(s) xstrlwr (s)
		167
		168	#else
174	#define stricmp(a,b) strcmp (a, b)	169	# define stricmp(a,b) strcmp (a, b)
175	#define strlwr(s) (s)	170	# define strlwr(s) (s)
		171	#endif
176		172
177	#ifndef prompt	173	#ifndef prompt
178	# define prompt "ts> "	174	# define prompt "ts> "
179	#endif	175	#endif
180		176
…		…
223	#if USE_MATH	219	#if USE_MATH
224	static double round_per_R5RS (double x);	220	static double round_per_R5RS (double x);
225	#endif	221	#endif
226	static int is_zero_rvalue (RVALUE x);	222	static int is_zero_rvalue (RVALUE x);
227		223
228	static INLINE int
229	num_is_integer (pointer p)
230	{
231	return num_is_fixnum (p->object.number);
232	}
233
234	static num num_zero;	224	static num num_zero;
235	static num num_one;	225	static num num_one;
236		226
237	/* macros for cell operations */	227	/* macros for cell operations */
238	#define typeflag(p) ((p)->flag + 0)	228	#define typeflag(p) ((p)->flag + 0)
239	#define set_typeflag(p,v) ((p)->flag = (v))	229	#define set_typeflag(p,v) ((p)->flag = (v))
240	#define type(p) (typeflag (p) & T_MASKTYPE)	230	#define type(p) (typeflag (p) & T_MASKTYPE)
241		231
242	INTERFACE INLINE int	232	INTERFACE int
243	is_string (pointer p)	233	is_string (pointer p)
244	{	234	{
245	return type (p) == T_STRING;	235	return type (p) == T_STRING;
246	}	236	}
247		237
248	#define strvalue(p) ((p)->object.string.svalue)	238	#define strvalue(p) ((p)->object.string.svalue)
249	#define strlength(p) ((p)->object.string.length)	239	#define strlength(p) ((p)->object.string.length)
250		240
251	INTERFACE int is_list (SCHEME_P_ pointer p);	241	INTERFACE int is_list (SCHEME_P_ pointer p);
		242
252	INTERFACE INLINE int	243	INTERFACE int
253	is_vector (pointer p)	244	is_vector (pointer p)
254	{	245	{
255	return type (p) == T_VECTOR;	246	return type (p) == T_VECTOR;
256	}	247	}
257		248
…		…
266	vector_length (pointer vec)	257	vector_length (pointer vec)
267	{	258	{
268	return vec->object.vector.length;	259	return vec->object.vector.length;
269	}	260	}
270		261
271	INTERFACE INLINE int	262	INTERFACE int
272	is_number (pointer p)	263	is_number (pointer p)
273	{	264	{
274	return type (p) == T_NUMBER;	265	return type (p) == T_NUMBER;
275	}	266	}
276		267
277	INTERFACE INLINE int	268	INTERFACE int
278	is_integer (pointer p)	269	is_integer (pointer p)
279	{	270	{
280	if (!is_number (p))	271	return is_number (p) && num_is_fixnum (p->object.number);
281	return 0;
282
283	if (num_is_integer (p) || ivalue (p) == rvalue (p))
284	return 1;
285
286	return 0;
287	}	272	}
288		273
289	INTERFACE INLINE int	274	INTERFACE int
290	is_real (pointer p)	275	is_real (pointer p)
291	{	276	{
292	return is_number (p) && !num_is_fixnum (p->object.number);	277	return is_number (p) && !num_is_fixnum (p->object.number);
293	}	278	}
294		279
295	INTERFACE INLINE int	280	INTERFACE int
296	is_character (pointer p)	281	is_character (pointer p)
297	{	282	{
298	return type (p) == T_CHARACTER;	283	return type (p) == T_CHARACTER;
299	}	284	}
300		285
301	INTERFACE INLINE char *	286	INTERFACE char *
302	string_value (pointer p)	287	string_value (pointer p)
303	{	288	{
304	return strvalue (p);	289	return strvalue (p);
305	}	290	}
306		291
307	INLINE num	292	ecb_inline num
308	nvalue (pointer p)	293	nvalue (pointer p)
309	{	294	{
310	return (p)->object.number;	295	return (p)->object.number;
311	}	296	}
312		297
…		…
342	#else	327	#else
343	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)	328	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
344	# define set_num_integer(p) 0	329	# define set_num_integer(p) 0
345	# define set_num_real(p) 0	330	# define set_num_real(p) 0
346	#endif	331	#endif
		332
347	INTERFACE long	333	INTERFACE long
348	charvalue (pointer p)	334	charvalue (pointer p)
349	{	335	{
350	return ivalue_unchecked (p);	336	return ivalue_unchecked (p);
351	}	337	}
352		338
353	INTERFACE INLINE int	339	INTERFACE int
354	is_port (pointer p)	340	is_port (pointer p)
355	{	341	{
356	return type (p) == T_PORT;	342	return type (p) == T_PORT;
357	}	343	}
358		344
359	INTERFACE INLINE int	345	INTERFACE int
360	is_inport (pointer p)	346	is_inport (pointer p)
361	{	347	{
362	return is_port (p) && p->object.port->kind & port_input;	348	return is_port (p) && p->object.port->kind & port_input;
363	}	349	}
364		350
365	INTERFACE INLINE int	351	INTERFACE int
366	is_outport (pointer p)	352	is_outport (pointer p)
367	{	353	{
368	return is_port (p) && p->object.port->kind & port_output;	354	return is_port (p) && p->object.port->kind & port_output;
369	}	355	}
370		356
371	INTERFACE INLINE int	357	INTERFACE int
372	is_pair (pointer p)	358	is_pair (pointer p)
373	{	359	{
374	return type (p) == T_PAIR;	360	return type (p) == T_PAIR;
375	}	361	}
376		362
…		…
408	pair_cdr (pointer p)	394	pair_cdr (pointer p)
409	{	395	{
410	return cdr (p);	396	return cdr (p);
411	}	397	}
412		398
413	INTERFACE INLINE int	399	INTERFACE int
414	is_symbol (pointer p)	400	is_symbol (pointer p)
415	{	401	{
416	return type (p) == T_SYMBOL;	402	return type (p) == T_SYMBOL;
417	}	403	}
418		404
419	INTERFACE INLINE char *	405	INTERFACE char *
420	symname (pointer p)	406	symname (pointer p)
421	{	407	{
422	return strvalue (car (p));	408	return strvalue (car (p));
423	}	409	}
424		410
425	#if USE_PLIST	411	#if USE_PLIST
426	SCHEME_EXPORT INLINE int	412	SCHEME_EXPORT int
427	hasprop (pointer p)	413	hasprop (pointer p)
428	{	414	{
429	return typeflag (p) & T_SYMBOL;	415	return typeflag (p) & T_SYMBOL;
430	}	416	}
431		417
432	# define symprop(p) cdr(p)	418	# define symprop(p) cdr(p)
433	#endif	419	#endif
434		420
435	INTERFACE INLINE int	421	INTERFACE int
436	is_syntax (pointer p)	422	is_syntax (pointer p)
437	{	423	{
438	return typeflag (p) & T_SYNTAX;	424	return typeflag (p) & T_SYNTAX;
439	}	425	}
440		426
441	INTERFACE INLINE int	427	INTERFACE int
442	is_proc (pointer p)	428	is_proc (pointer p)
443	{	429	{
444	return type (p) == T_PROC;	430	return type (p) == T_PROC;
445	}	431	}
446		432
447	INTERFACE INLINE int	433	INTERFACE int
448	is_foreign (pointer p)	434	is_foreign (pointer p)
449	{	435	{
450	return type (p) == T_FOREIGN;	436	return type (p) == T_FOREIGN;
451	}	437	}
452		438
453	INTERFACE INLINE char *	439	INTERFACE char *
454	syntaxname (pointer p)	440	syntaxname (pointer p)
455	{	441	{
456	return strvalue (car (p));	442	return strvalue (car (p));
457	}	443	}
458		444
459	#define procnum(p) ivalue (p)	445	#define procnum(p) ivalue (p)
460	static const char *procname (pointer x);	446	static const char *procname (pointer x);
461		447
462	INTERFACE INLINE int	448	INTERFACE int
463	is_closure (pointer p)	449	is_closure (pointer p)
464	{	450	{
465	return type (p) == T_CLOSURE;	451	return type (p) == T_CLOSURE;
466	}	452	}
467		453
468	INTERFACE INLINE int	454	INTERFACE int
469	is_macro (pointer p)	455	is_macro (pointer p)
470	{	456	{
471	return type (p) == T_MACRO;	457	return type (p) == T_MACRO;
472	}	458	}
473		459
474	INTERFACE INLINE pointer	460	INTERFACE pointer
475	closure_code (pointer p)	461	closure_code (pointer p)
476	{	462	{
477	return car (p);	463	return car (p);
478	}	464	}
479		465
480	INTERFACE INLINE pointer	466	INTERFACE pointer
481	closure_env (pointer p)	467	closure_env (pointer p)
482	{	468	{
483	return cdr (p);	469	return cdr (p);
484	}	470	}
485		471
486	INTERFACE INLINE int	472	INTERFACE int
487	is_continuation (pointer p)	473	is_continuation (pointer p)
488	{	474	{
489	return type (p) == T_CONTINUATION;	475	return type (p) == T_CONTINUATION;
490	}	476	}
491		477
492	#define cont_dump(p) cdr (p)	478	#define cont_dump(p) cdr (p)
493	#define set_cont_dump(p,v) set_cdr ((p), (v))	479	#define set_cont_dump(p,v) set_cdr ((p), (v))
494		480
495	/* To do: promise should be forced ONCE only */	481	/* To do: promise should be forced ONCE only */
496	INTERFACE INLINE int	482	INTERFACE int
497	is_promise (pointer p)	483	is_promise (pointer p)
498	{	484	{
499	return type (p) == T_PROMISE;	485	return type (p) == T_PROMISE;
500	}	486	}
501		487
502	INTERFACE INLINE int	488	INTERFACE int
503	is_environment (pointer p)	489	is_environment (pointer p)
504	{	490	{
505	return type (p) == T_ENVIRONMENT;	491	return type (p) == T_ENVIRONMENT;
506	}	492	}
507		493
…		…
513		499
514	#define is_mark(p) (typeflag (p) & T_MARK)	500	#define is_mark(p) (typeflag (p) & T_MARK)
515	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)	501	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
516	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	502	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
517		503
518	INTERFACE INLINE int	504	INTERFACE int
519	is_immutable (pointer p)	505	is_immutable (pointer p)
520	{	506	{
521	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	507	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
522	}	508	}
523		509
524	INTERFACE INLINE void	510	INTERFACE void
525	setimmutable (pointer p)	511	setimmutable (pointer p)
526	{	512	{
527	#if USE_ERROR_CHECKING	513	#if USE_ERROR_CHECKING
528	set_typeflag (p, typeflag (p) | T_IMMUTABLE);	514	set_typeflag (p, typeflag (p) | T_IMMUTABLE);
529	#endif	515	#endif
530	}	516	}
531		517
532	#if USE_CHAR_CLASSIFIERS	518	#if USE_CHAR_CLASSIFIERS
533	static INLINE int	519	ecb_inline int
534	Cisalpha (int c)	520	Cisalpha (int c)
535	{	521	{
536	return isascii (c) && isalpha (c);	522	return isascii (c) && isalpha (c);
537	}	523	}
538		524
539	static INLINE int	525	ecb_inline int
540	Cisdigit (int c)	526	Cisdigit (int c)
541	{	527	{
542	return isascii (c) && isdigit (c);	528	return isascii (c) && isdigit (c);
543	}	529	}
544		530
545	static INLINE int	531	ecb_inline int
546	Cisspace (int c)	532	Cisspace (int c)
547	{	533	{
548	return isascii (c) && isspace (c);	534	return isascii (c) && isspace (c);
549	}	535	}
550		536
551	static INLINE int	537	ecb_inline int
552	Cisupper (int c)	538	Cisupper (int c)
553	{	539	{
554	return isascii (c) && isupper (c);	540	return isascii (c) && isupper (c);
555	}	541	}
556		542
557	static INLINE int	543	ecb_inline int
558	Cislower (int c)	544	Cislower (int c)
559	{	545	{
560	return isascii (c) && islower (c);	546	return isascii (c) && islower (c);
561	}	547	}
562	#endif	548	#endif
…		…
623	#endif	609	#endif
624		610
625	static int file_push (SCHEME_P_ const char *fname);	611	static int file_push (SCHEME_P_ const char *fname);
626	static void file_pop (SCHEME_P);	612	static void file_pop (SCHEME_P);
627	static int file_interactive (SCHEME_P);	613	static int file_interactive (SCHEME_P);
628	static INLINE int is_one_of (char *s, int c);	614	ecb_inline int is_one_of (char *s, int c);
629	static int alloc_cellseg (SCHEME_P_ int n);	615	static int alloc_cellseg (SCHEME_P_ int n);
630	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);	616	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
631	static void finalize_cell (SCHEME_P_ pointer a);	617	static void finalize_cell (SCHEME_P_ pointer a);
632	static int count_consecutive_cells (pointer x, int needed);	618	static int count_consecutive_cells (pointer x, int needed);
633	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	619	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
634	static pointer mk_number (SCHEME_P_ const num n);	620	static pointer mk_number (SCHEME_P_ const num n);
635	static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);	621	static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
…		…
652	static int basic_inchar (port *pt);	638	static int basic_inchar (port *pt);
653	static int inchar (SCHEME_P);	639	static int inchar (SCHEME_P);
654	static void backchar (SCHEME_P_ int c);	640	static void backchar (SCHEME_P_ int c);
655	static char *readstr_upto (SCHEME_P_ char *delim);	641	static char *readstr_upto (SCHEME_P_ char *delim);
656	static pointer readstrexp (SCHEME_P);	642	static pointer readstrexp (SCHEME_P);
657	static INLINE int skipspace (SCHEME_P);	643	ecb_inline int skipspace (SCHEME_P);
658	static int token (SCHEME_P);	644	static int token (SCHEME_P);
659	static void printslashstring (SCHEME_P_ char *s, int len);	645	static void printslashstring (SCHEME_P_ char *s, int len);
660	static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);	646	static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
661	static void printatom (SCHEME_P_ pointer l, int f);	647	static void printatom (SCHEME_P_ pointer l, int f);
662	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	648	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
666	static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);	652	static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
667	static pointer revappend (SCHEME_P_ pointer a, pointer b);	653	static pointer revappend (SCHEME_P_ pointer a, pointer b);
668	static pointer ss_get_cont (SCHEME_P);	654	static pointer ss_get_cont (SCHEME_P);
669	static void ss_set_cont (SCHEME_P_ pointer cont);	655	static void ss_set_cont (SCHEME_P_ pointer cont);
670	static void dump_stack_mark (SCHEME_P);	656	static void dump_stack_mark (SCHEME_P);
671	static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);	657	static int opexe_0 (SCHEME_P_ enum scheme_opcodes op);
		658	static int opexe_1 (SCHEME_P_ enum scheme_opcodes op);
672	static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op);	659	static int opexe_2 (SCHEME_P_ enum scheme_opcodes op);
673	static pointer opexe_r (SCHEME_P_ enum scheme_opcodes op);
674	static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);	660	static int opexe_3 (SCHEME_P_ enum scheme_opcodes op);
675	static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);	661	static int opexe_4 (SCHEME_P_ enum scheme_opcodes op);
676	static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);	662	static int opexe_5 (SCHEME_P_ enum scheme_opcodes op);
677	static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);	663	static int opexe_6 (SCHEME_P_ enum scheme_opcodes op);
678	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);	664	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
679	static void assign_syntax (SCHEME_P_ const char *name);	665	static void assign_syntax (SCHEME_P_ const char *name);
680	static int syntaxnum (pointer p);	666	static int syntaxnum (pointer p);
681	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);	667	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
682		668
…		…
780		766
781	num_set_ivalue (ret, res);	767	num_set_ivalue (ret, res);
782	return ret;	768	return ret;
783	}	769	}
784		770
785	/* this completely disrespects NaNs */	771	/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
786	static int	772	static int
787	num_cmp (num a, num b)	773	num_cmp (num a, num b)
788	{	774	{
789	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);	775	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
790	int ret;	776	int ret;
…		…
833	#endif	819	#endif
834		820
835	static int	821	static int
836	is_zero_rvalue (RVALUE x)	822	is_zero_rvalue (RVALUE x)
837	{	823	{
		824	return x == 0;
		825	#if 0
838	#if USE_REAL	826	#if USE_REAL
839	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */	827	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
840	#else	828	#else
841	return x == 0;	829	return x == 0;
		830	#endif
842	#endif	831	#endif
843	}	832	}
844		833
845	/* allocate new cell segment */	834	/* allocate new cell segment */
846	static int	835	static int
…		…
918		907
919	return n;	908	return n;
920	}	909	}
921		910
922	/* get new cell. parameter a, b is marked by gc. */	911	/* get new cell. parameter a, b is marked by gc. */
923	static INLINE pointer	912	ecb_inline pointer
924	get_cell_x (SCHEME_P_ pointer a, pointer b)	913	get_cell_x (SCHEME_P_ pointer a, pointer b)
925	{	914	{
926	if (ecb_expect_false (SCHEME_V->free_cell == NIL))	915	if (ecb_expect_false (SCHEME_V->free_cell == NIL))
927	{	916	{
928	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	917	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
…		…
1006	push_recent_alloc (SCHEME_A_ v, NIL);	995	push_recent_alloc (SCHEME_A_ v, NIL);
1007		996
1008	return v;	997	return v;
1009	}	998	}
1010		999
1011	static INLINE void	1000	ecb_inline void
1012	ok_to_freely_gc (SCHEME_P)	1001	ok_to_freely_gc (SCHEME_P)
1013	{	1002	{
1014	set_car (S_SINK, NIL);	1003	set_car (S_SINK, NIL);
1015	}	1004	}
1016		1005
…		…
1080	location = hash_fn (name, veclength (SCHEME_V->oblist));	1069	location = hash_fn (name, veclength (SCHEME_V->oblist));
1081	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));	1070	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1082	return x;	1071	return x;
1083	}	1072	}
1084		1073
1085	static INLINE pointer	1074	ecb_inline pointer
1086	oblist_find_by_name (SCHEME_P_ const char *name)	1075	oblist_find_by_name (SCHEME_P_ const char *name)
1087	{	1076	{
1088	int location;	1077	int location;
1089	pointer x;	1078	pointer x;
1090	char *s;	1079	char *s;
…		…
1123	oblist_initial_value (SCHEME_P)	1112	oblist_initial_value (SCHEME_P)
1124	{	1113	{
1125	return NIL;	1114	return NIL;
1126	}	1115	}
1127		1116
1128	static INLINE pointer	1117	ecb_inline pointer
1129	oblist_find_by_name (SCHEME_P_ const char *name)	1118	oblist_find_by_name (SCHEME_P_ const char *name)
1130	{	1119	{
1131	pointer x;	1120	pointer x;
1132	char *s;	1121	char *s;
1133		1122
…		…
2231	}	2220	}
2232	}	2221	}
2233	}	2222	}
2234		2223
2235	/* check c is in chars */	2224	/* check c is in chars */
2236	static INLINE int	2225	ecb_inline int
2237	is_one_of (char *s, int c)	2226	is_one_of (char *s, int c)
2238	{	2227	{
2239	if (c == EOF)	2228	if (c == EOF)
2240	return 1;	2229	return 1;
2241		2230
2242	return !!strchr (s, c);	2231	return !!strchr (s, c);
2243	}	2232	}
2244		2233
2245	/* skip white characters */	2234	/* skip white characters */
2246	static INLINE int	2235	ecb_inline int
2247	skipspace (SCHEME_P)	2236	skipspace (SCHEME_P)
2248	{	2237	{
2249	int c, curr_line = 0;	2238	int c, curr_line = 0;
2250		2239
2251	do	2240	do
…		…
2479	{	2468	{
2480	p = SCHEME_V->strbuff;	2469	p = SCHEME_V->strbuff;
2481		2470
2482	if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */	2471	if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2483	{	2472	{
2484	if (num_is_integer (l))	2473	if (is_integer (l))
2485	xnum (p, ivalue_unchecked (l));	2474	xnum (p, ivalue_unchecked (l));
2486	#if USE_REAL	2475	#if USE_REAL
2487	else	2476	else
2488	{	2477	{
2489	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));	2478	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
…		…
2744	return 0;	2733	return 0;
2745	}	2734	}
2746	else if (is_number (a))	2735	else if (is_number (a))
2747	{	2736	{
2748	if (is_number (b))	2737	if (is_number (b))
2749	if (num_is_integer (a) == num_is_integer (b))
2750	return num_cmp (nvalue (a), nvalue (b)) == 0;	2738	return num_cmp (nvalue (a), nvalue (b)) == 0;
2751		2739
2752	return 0;	2740	return 0;
2753	}	2741	}
2754	else if (is_character (a))	2742	else if (is_character (a))
2755	{	2743	{
…		…
2822		2810
2823	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2811	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2824	setenvironment (SCHEME_V->envir);	2812	setenvironment (SCHEME_V->envir);
2825	}	2813	}
2826		2814
2827	static INLINE void	2815	ecb_inline void
2828	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2816	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2829	{	2817	{
2830	pointer slot = immutable_cons (variable, value);	2818	pointer slot = immutable_cons (variable, value);
2831		2819
2832	if (is_vector (car (env)))	2820	if (is_vector (car (env)))
…		…
2872	return NIL;	2860	return NIL;
2873	}	2861	}
2874		2862
2875	#else /* USE_ALIST_ENV */	2863	#else /* USE_ALIST_ENV */
2876		2864
2877	static INLINE void	2865	ecb_inline void
2878	new_frame_in_env (SCHEME_P_ pointer old_env)	2866	new_frame_in_env (SCHEME_P_ pointer old_env)
2879	{	2867	{
2880	SCHEME_V->envir = immutable_cons (NIL, old_env);	2868	SCHEME_V->envir = immutable_cons (NIL, old_env);
2881	setenvironment (SCHEME_V->envir);	2869	setenvironment (SCHEME_V->envir);
2882	}	2870	}
2883		2871
2884	static INLINE void	2872	ecb_inline void
2885	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2873	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2886	{	2874	{
2887	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2875	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2888	}	2876	}
2889		2877
…		…
2911	return NIL;	2899	return NIL;
2912	}	2900	}
2913		2901
2914	#endif /* USE_ALIST_ENV else */	2902	#endif /* USE_ALIST_ENV else */
2915		2903
2916	static INLINE void	2904	ecb_inline void
2917	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2905	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2918	{	2906	{
2919	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);	2907	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2920	}	2908	}
2921		2909
2922	static INLINE void	2910	ecb_inline void
2923	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2911	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2924	{	2912	{
2925	set_cdr (slot, value);	2913	set_cdr (slot, value);
2926	}	2914	}
2927		2915
2928	static INLINE pointer	2916	ecb_inline pointer
2929	slot_value_in_env (pointer slot)	2917	slot_value_in_env (pointer slot)
2930	{	2918	{
2931	return cdr (slot);	2919	return cdr (slot);
2932	}	2920	}
2933		2921
2934	/* ========== Evaluation Cycle ========== */	2922	/* ========== Evaluation Cycle ========== */
2935		2923
2936	static pointer	2924	static int
2937	xError_1 (SCHEME_P_ const char *s, pointer a)	2925	xError_1 (SCHEME_P_ const char *s, pointer a)
2938	{	2926	{
2939	#if USE_ERROR_HOOK	2927	#if USE_ERROR_HOOK
2940	pointer x;	2928	pointer x;
2941	pointer hdl = SCHEME_V->ERROR_HOOK;	2929	pointer hdl = SCHEME_V->ERROR_HOOK;
…		…
2976	code = cons (mk_string (SCHEME_A_ s), code);	2964	code = cons (mk_string (SCHEME_A_ s), code);
2977	setimmutable (car (code));	2965	setimmutable (car (code));
2978	SCHEME_V->code = cons (slot_value_in_env (x), code);	2966	SCHEME_V->code = cons (slot_value_in_env (x), code);
2979	SCHEME_V->op = OP_EVAL;	2967	SCHEME_V->op = OP_EVAL;
2980		2968
2981	return S_T;	2969	return 0;
2982	}	2970	}
2983	#endif	2971	#endif
2984		2972
2985	if (a)	2973	if (a)
2986	SCHEME_V->args = cons (a, NIL);	2974	SCHEME_V->args = cons (a, NIL);
…		…
2988	SCHEME_V->args = NIL;	2976	SCHEME_V->args = NIL;
2989		2977
2990	SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);	2978	SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
2991	setimmutable (car (SCHEME_V->args));	2979	setimmutable (car (SCHEME_V->args));
2992	SCHEME_V->op = OP_ERR0;	2980	SCHEME_V->op = OP_ERR0;
		2981
2993	return S_T;	2982	return 0;
2994	}	2983	}
2995		2984
2996	#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)	2985	#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
2997	#define Error_0(s) Error_1 (s, 0)	2986	#define Error_0(s) Error_1 (s, 0)
2998		2987
2999	/* Too small to turn into function */	2988	/* Too small to turn into function */
3000	#define BEGIN do {	2989	#define BEGIN do {
3001	#define END } while (0)	2990	#define END } while (0)
3002	#define s_goto(a) BEGIN \	2991	#define s_goto(a) BEGIN \
3003	SCHEME_V->op = a; \	2992	SCHEME_V->op = a; \
3004	return S_T; END	2993	return 0; END
3005		2994
3006	#define s_return(a) return xs_return (SCHEME_A_ a)	2995	#define s_return(a) return xs_return (SCHEME_A_ a)
3007		2996
3008	#ifndef USE_SCHEME_STACK	2997	#ifndef USE_SCHEME_STACK
3009		2998
…		…
3039	next_frame->code = code;	3028	next_frame->code = code;
3040		3029
3041	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3030	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3042	}	3031	}
3043		3032
3044	static pointer	3033	static int
3045	xs_return (SCHEME_P_ pointer a)	3034	xs_return (SCHEME_P_ pointer a)
3046	{	3035	{
3047	int nframes = (uintptr_t)SCHEME_V->dump;	3036	int nframes = (uintptr_t)SCHEME_V->dump;
3048	struct dump_stack_frame *frame;	3037	struct dump_stack_frame *frame;
3049		3038
3050	SCHEME_V->value = a;	3039	SCHEME_V->value = a;
3051		3040
3052	if (nframes <= 0)	3041	if (nframes <= 0)
3053	return NIL;	3042	return -1;
3054		3043
3055	frame = &SCHEME_V->dump_base[--nframes];	3044	frame = &SCHEME_V->dump_base[--nframes];
3056	SCHEME_V->op = frame->op;	3045	SCHEME_V->op = frame->op;
3057	SCHEME_V->args = frame->args;	3046	SCHEME_V->args = frame->args;
3058	SCHEME_V->envir = frame->envir;	3047	SCHEME_V->envir = frame->envir;
3059	SCHEME_V->code = frame->code;	3048	SCHEME_V->code = frame->code;
3060	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3049	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3061		3050
3062	return S_T;	3051	return 0;
3063	}	3052	}
3064		3053
3065	static INLINE void	3054	ecb_inline void
3066	dump_stack_reset (SCHEME_P)	3055	dump_stack_reset (SCHEME_P)
3067	{	3056	{
3068	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */	3057	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3069	SCHEME_V->dump = (pointer)+0;	3058	SCHEME_V->dump = (pointer)+0;
3070	}	3059	}
3071		3060
3072	static INLINE void	3061	ecb_inline void
3073	dump_stack_initialize (SCHEME_P)	3062	dump_stack_initialize (SCHEME_P)
3074	{	3063	{
3075	SCHEME_V->dump_size = 0;	3064	SCHEME_V->dump_size = 0;
3076	SCHEME_V->dump_base = 0;	3065	SCHEME_V->dump_base = 0;
3077	dump_stack_reset (SCHEME_A);	3066	dump_stack_reset (SCHEME_A);
…		…
3144	SCHEME_V->dump = (pointer)(uintptr_t)i;	3133	SCHEME_V->dump = (pointer)(uintptr_t)i;
3145	}	3134	}
3146		3135
3147	#else	3136	#else
3148		3137
3149	static INLINE void	3138	ecb_inline void
3150	dump_stack_reset (SCHEME_P)	3139	dump_stack_reset (SCHEME_P)
3151	{	3140	{
3152	SCHEME_V->dump = NIL;	3141	SCHEME_V->dump = NIL;
3153	}	3142	}
3154		3143
3155	static INLINE void	3144	ecb_inline void
3156	dump_stack_initialize (SCHEME_P)	3145	dump_stack_initialize (SCHEME_P)
3157	{	3146	{
3158	dump_stack_reset (SCHEME_A);	3147	dump_stack_reset (SCHEME_A);
3159	}	3148	}
3160		3149
…		…
3162	dump_stack_free (SCHEME_P)	3151	dump_stack_free (SCHEME_P)
3163	{	3152	{
3164	SCHEME_V->dump = NIL;	3153	SCHEME_V->dump = NIL;
3165	}	3154	}
3166		3155
3167	static pointer	3156	static int
3168	xs_return (SCHEME_P_ pointer a)	3157	xs_return (SCHEME_P_ pointer a)
3169	{	3158	{
3170	pointer dump = SCHEME_V->dump;	3159	pointer dump = SCHEME_V->dump;
3171		3160
3172	SCHEME_V->value = a;	3161	SCHEME_V->value = a;
3173		3162
3174	if (dump == NIL)	3163	if (dump == NIL)
3175	return NIL;	3164	return -1;
3176		3165
3177	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);	3166	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);
3178	SCHEME_V->args = car (dump) ; dump = cdr (dump);	3167	SCHEME_V->args = car (dump) ; dump = cdr (dump);
3179	SCHEME_V->envir = car (dump) ; dump = cdr (dump);	3168	SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3180	SCHEME_V->code = car (dump) ; dump = cdr (dump);	3169	SCHEME_V->code = car (dump) ; dump = cdr (dump);
3181		3170
3182	SCHEME_V->dump = dump;	3171	SCHEME_V->dump = dump;
3183		3172
3184	return S_T;	3173	return 0;
3185	}	3174	}
3186		3175
3187	static void	3176	static void
3188	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)	3177	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3189	{	3178	{
…		…
3214		3203
3215	#endif	3204	#endif
3216		3205
3217	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3206	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3218		3207
3219	static pointer	3208	static int
3220	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3209	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3221	{	3210	{
3222	pointer args = SCHEME_V->args;	3211	pointer args = SCHEME_V->args;
3223	pointer x, y;	3212	pointer x, y;
3224		3213
…		…
3413	/* fall through */	3402	/* fall through */
3414		3403
3415	case OP_REAL_APPLY:	3404	case OP_REAL_APPLY:
3416	#endif	3405	#endif
3417	if (is_proc (SCHEME_V->code))	3406	if (is_proc (SCHEME_V->code))
3418	{
3419	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */	3407	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3420	}
3421	else if (is_foreign (SCHEME_V->code))	3408	else if (is_foreign (SCHEME_V->code))
3422	{	3409	{
3423	/* Keep nested calls from GC'ing the arglist */	3410	/* Keep nested calls from GC'ing the arglist */
3424	push_recent_alloc (SCHEME_A_ args, NIL);	3411	push_recent_alloc (SCHEME_A_ args, NIL);
3425	x = SCHEME_V->code->object.ff (SCHEME_A_ args);	3412	x = SCHEME_V->code->object.ff (SCHEME_A_ args);
…		…
3592		3579
3593	case OP_IF1: /* if */	3580	case OP_IF1: /* if */
3594	if (is_true (SCHEME_V->value))	3581	if (is_true (SCHEME_V->value))
3595	SCHEME_V->code = car (SCHEME_V->code);	3582	SCHEME_V->code = car (SCHEME_V->code);
3596	else	3583	else
3597	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because	3584	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3598
3599	* car(NIL) = NIL */
3600	s_goto (OP_EVAL);	3585	s_goto (OP_EVAL);
3601		3586
3602	case OP_LET0: /* let */	3587	case OP_LET0: /* let */
3603	SCHEME_V->args = NIL;	3588	SCHEME_V->args = NIL;
3604	SCHEME_V->value = SCHEME_V->code;	3589	SCHEME_V->value = SCHEME_V->code;
…		…
3914	SCHEME_V->code = car (args);	3899	SCHEME_V->code = car (args);
3915	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);	3900	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3916	s_goto (OP_APPLY);	3901	s_goto (OP_APPLY);
3917	}	3902	}
3918		3903
3919	abort ();	3904	if (USE_ERROR_CHECKING) abort ();
3920	}	3905	}
3921		3906
3922	static pointer	3907	static int
3923	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	3908	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3924	{	3909	{
3925	pointer args = SCHEME_V->args;	3910	pointer args = SCHEME_V->args;
3926	pointer x = car (args);	3911	pointer x = car (args);
3927	num v;	3912	num v;
3928		3913
…		…
3932		3917
3933	switch (op)	3918	switch (op)
3934	{	3919	{
3935	#if USE_MATH	3920	#if USE_MATH
3936	case OP_INEX2EX: /* inexact->exact */	3921	case OP_INEX2EX: /* inexact->exact */
3937	if (num_is_integer (x))	3922	if (is_integer (x))
3938	s_return (x);	3923	s_return (x);
3939	else if (modf (rvalue_unchecked (x), &dd) == 0)	3924	else if (modf (rvalue_unchecked (x), &dd) == 0)
3940	s_return (mk_integer (SCHEME_A_ ivalue (x)));	3925	s_return (mk_integer (SCHEME_A_ ivalue (x)));
3941	else	3926	else
3942	Error_1 ("inexact->exact: not integral:", x);	3927	Error_1 ("inexact->exact: not integral:", x);
…		…
3965	{	3950	{
3966	RVALUE result;	3951	RVALUE result;
3967	int real_result = 1;	3952	int real_result = 1;
3968	pointer y = cadr (args);	3953	pointer y = cadr (args);
3969		3954
3970	if (num_is_integer (x) && num_is_integer (y))	3955	if (is_integer (x) && is_integer (y))
3971	real_result = 0;	3956	real_result = 0;
3972		3957
3973	/* This 'if' is an R5RS compatibility fix. */	3958	/* This 'if' is an R5RS compatibility fix. */
3974	/* NOTE: Remove this 'if' fix for R6RS. */	3959	/* NOTE: Remove this 'if' fix for R6RS. */
3975	if (rvalue (x) == 0 && rvalue (y) < 0)	3960	if (rvalue (x) == 0 && rvalue (y) < 0)
…		…
4017		4002
4018	case OP_ADD: /* + */	4003	case OP_ADD: /* + */
4019	v = num_zero;	4004	v = num_zero;
4020		4005
4021	for (x = args; x != NIL; x = cdr (x))	4006	for (x = args; x != NIL; x = cdr (x))
4022	v = num_op ('+', v, nvalue (car (x)));	4007	v = num_op (NUM_ADD, v, nvalue (car (x)));
4023		4008
4024	s_return (mk_number (SCHEME_A_ v));	4009	s_return (mk_number (SCHEME_A_ v));
4025		4010
4026	case OP_MUL: /* * */	4011	case OP_MUL: /* * */
4027	v = num_one;	4012	v = num_one;
4028		4013
4029	for (x = args; x != NIL; x = cdr (x))	4014	for (x = args; x != NIL; x = cdr (x))
4030	v = num_op ('+', v, nvalue (car (x)));	4015	v = num_op (NUM_MUL, v, nvalue (car (x)));
4031		4016
4032	s_return (mk_number (SCHEME_A_ v));	4017	s_return (mk_number (SCHEME_A_ v));
4033		4018
4034	case OP_SUB: /* - */	4019	case OP_SUB: /* - */
4035	if (cdr (args) == NIL)	4020	if (cdr (args) == NIL)
…		…
4042	x = cdr (args);	4027	x = cdr (args);
4043	v = nvalue (car (args));	4028	v = nvalue (car (args));
4044	}	4029	}
4045		4030
4046	for (; x != NIL; x = cdr (x))	4031	for (; x != NIL; x = cdr (x))
4047	v = num_op ('+', v, nvalue (car (x)));	4032	v = num_op (NUM_SUB, v, nvalue (car (x)));
4048		4033
4049	s_return (mk_number (SCHEME_A_ v));	4034	s_return (mk_number (SCHEME_A_ v));
4050		4035
4051	case OP_DIV: /* / */	4036	case OP_DIV: /* / */
4052	if (cdr (args) == NIL)	4037	if (cdr (args) == NIL)
…		…
4059	x = cdr (args);	4044	x = cdr (args);
4060	v = nvalue (car (args));	4045	v = nvalue (car (args));
4061	}	4046	}
4062		4047
4063	for (; x != NIL; x = cdr (x))	4048	for (; x != NIL; x = cdr (x))
4064	{
4065	if (!is_zero_rvalue (rvalue (car (x))))	4049	if (!is_zero_rvalue (rvalue (car (x))))
4066	v = num_div (v, nvalue (car (x)));	4050	v = num_div (v, nvalue (car (x)));
4067	else	4051	else
4068	Error_0 ("/: division by zero");	4052	Error_0 ("/: division by zero");
4069	}
4070		4053
4071	s_return (mk_number (SCHEME_A_ v));	4054	s_return (mk_number (SCHEME_A_ v));
4072		4055
4073	case OP_INTDIV: /* quotient */	4056	case OP_INTDIV: /* quotient */
4074	if (cdr (args) == NIL)	4057	if (cdr (args) == NIL)
…		…
4083	}	4066	}
4084		4067
4085	for (; x != NIL; x = cdr (x))	4068	for (; x != NIL; x = cdr (x))
4086	{	4069	{
4087	if (ivalue (car (x)) != 0)	4070	if (ivalue (car (x)) != 0)
4088	v = num_op ('/', v, nvalue (car (x)));	4071	v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4089	else	4072	else
4090	Error_0 ("quotient: division by zero");	4073	Error_0 ("quotient: division by zero");
4091	}	4074	}
4092		4075
4093	s_return (mk_number (SCHEME_A_ v));	4076	s_return (mk_number (SCHEME_A_ v));
…		…
4248	len = ivalue (x);	4231	len = ivalue (x);
4249		4232
4250	if (cdr (args) != NIL)	4233	if (cdr (args) != NIL)
4251	fill = charvalue (cadr (args));	4234	fill = charvalue (cadr (args));
4252		4235
4253	s_return (mk_empty_string (SCHEME_A_ len, (char) fill));	4236	s_return (mk_empty_string (SCHEME_A_ len, fill));
4254	}	4237	}
4255		4238
4256	case OP_STRLEN: /* string-length */	4239	case OP_STRLEN: /* string-length */
4257	s_return (mk_integer (SCHEME_A_ strlength (x)));	4240	s_return (mk_integer (SCHEME_A_ strlength (x)));
4258		4241
…		…
4266	index = ivalue (cadr (args));	4249	index = ivalue (cadr (args));
4267		4250
4268	if (index >= strlength (x))	4251	if (index >= strlength (x))
4269	Error_1 ("string-ref: out of bounds:", cadr (args));	4252	Error_1 ("string-ref: out of bounds:", cadr (args));
4270		4253
4271	s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index]));	4254	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4272	}	4255	}
4273		4256
4274	case OP_STRSET: /* string-set! */	4257	case OP_STRSET: /* string-set! */
4275	{	4258	{
4276	char *str;	4259	char *str;
…		…
4287	if (index >= strlength (x))	4270	if (index >= strlength (x))
4288	Error_1 ("string-set!: out of bounds:", cadr (args));	4271	Error_1 ("string-set!: out of bounds:", cadr (args));
4289		4272
4290	c = charvalue (caddr (args));	4273	c = charvalue (caddr (args));
4291		4274
4292	str[index] = (char)c;	4275	str[index] = c;
4293	s_return (car (args));	4276	s_return (car (args));
4294	}	4277	}
4295		4278
4296	case OP_STRAPPEND: /* string-append */	4279	case OP_STRAPPEND: /* string-append */
4297	{	4280	{
…		…
4421	set_vector_elem (x, index, caddr (args));	4404	set_vector_elem (x, index, caddr (args));
4422	s_return (x);	4405	s_return (x);
4423	}	4406	}
4424	}	4407	}
4425		4408
4426	return S_T;	4409	if (USE_ERROR_CHECKING) abort ();
4427	}	4410	}
4428		4411
4429	INTERFACE int	4412	INTERFACE int
4430	is_list (SCHEME_P_ pointer a)	4413	is_list (SCHEME_P_ pointer a)
4431	{	4414	{
…		…
4478	return -1;	4461	return -1;
4479	}	4462	}
4480	}	4463	}
4481	}	4464	}
4482		4465
4483	static pointer	4466	static int
4484	opexe_r (SCHEME_P_ enum scheme_opcodes op)	4467	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4485	{	4468	{
4486	pointer x = SCHEME_V->args;	4469	pointer x = SCHEME_V->args;
4487		4470
4488	for (;;)	4471	for (;;)
4489	{	4472	{
…		…
4509	}	4492	}
4510		4493
4511	s_return (S_T);	4494	s_return (S_T);
4512	}	4495	}
4513		4496
4514	static pointer	4497	static int
4515	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4498	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4516	{	4499	{
4517	pointer args = SCHEME_V->args;	4500	pointer args = SCHEME_V->args;
4518	pointer a = car (args);	4501	pointer a = car (args);
4519	pointer d = cdr (args);	4502	pointer d = cdr (args);
…		…
4565	}	4548	}
4566		4549
4567	s_retbool (r);	4550	s_retbool (r);
4568	}	4551	}
4569		4552
4570	static pointer	4553	static int
4571	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4554	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4572	{	4555	{
4573	pointer args = SCHEME_V->args;	4556	pointer args = SCHEME_V->args;
4574	pointer a = car (args);	4557	pointer a = car (args);
4575	pointer x, y;	4558	pointer x, y;
…		…
4661	putstr (SCHEME_A_ "\n");	4644	putstr (SCHEME_A_ "\n");
4662		4645
4663	if (SCHEME_V->interactive_repl)	4646	if (SCHEME_V->interactive_repl)
4664	s_goto (OP_T0LVL);	4647	s_goto (OP_T0LVL);
4665	else	4648	else
4666	return NIL;	4649	return -1;
4667	}	4650	}
4668		4651
4669	case OP_REVERSE: /* reverse */	4652	case OP_REVERSE: /* reverse */
4670	s_return (reverse (SCHEME_A_ a));	4653	s_return (reverse (SCHEME_A_ a));
4671		4654
…		…
4728		4711
4729	case OP_QUIT: /* quit */	4712	case OP_QUIT: /* quit */
4730	if (is_pair (args))	4713	if (is_pair (args))
4731	SCHEME_V->retcode = ivalue (a);	4714	SCHEME_V->retcode = ivalue (a);
4732		4715
4733	return NIL;	4716	return -1;
4734		4717
4735	case OP_GC: /* gc */	4718	case OP_GC: /* gc */
4736	gc (SCHEME_A_ NIL, NIL);	4719	gc (SCHEME_A_ NIL, NIL);
4737	s_return (S_T);	4720	s_return (S_T);
4738		4721
…		…
4785	break;	4768	break;
4786	}	4769	}
4787		4770
4788	p = port_from_filename (SCHEME_A_ strvalue (a), prop);	4771	p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4789		4772
4790	if (p == NIL)	4773	s_return (p == NIL ? S_F : p);
4791	s_return (S_F);
4792
4793	s_return (p);
4794	}	4774	}
4795		4775
4796	# if USE_STRING_PORTS	4776	# if USE_STRING_PORTS
4797		4777
4798	case OP_OPEN_INSTRING: /* open-input-string */	4778	case OP_OPEN_INSTRING: /* open-input-string */
…		…
4813	}	4793	}
4814		4794
4815	p = port_from_string (SCHEME_A_ strvalue (a),	4795	p = port_from_string (SCHEME_A_ strvalue (a),
4816	strvalue (a) + strlength (a), prop);	4796	strvalue (a) + strlength (a), prop);
4817		4797
4818	if (p == NIL)	4798	s_return (p == NIL ? S_F : p);
4819	s_return (S_F);
4820
4821	s_return (p);
4822	}	4799	}
4823		4800
4824	case OP_OPEN_OUTSTRING: /* open-output-string */	4801	case OP_OPEN_OUTSTRING: /* open-output-string */
4825	{	4802	{
4826	pointer p;	4803	pointer p;
4827		4804
4828	if (a == NIL)	4805	if (a == NIL)
4829	{
4830	p = port_from_scratch (SCHEME_A);	4806	p = port_from_scratch (SCHEME_A);
4831
4832	if (p == NIL)
4833	s_return (S_F);
4834	}
4835	else	4807	else
4836	{
4837	p = port_from_string (SCHEME_A_ strvalue (a),	4808	p = port_from_string (SCHEME_A_ strvalue (a),
4838	strvalue (a) + strlength (a), port_output);	4809	strvalue (a) + strlength (a), port_output);
4839		4810
4840	if (p == NIL)	4811	s_return (p == NIL ? S_F : p);
4841	s_return (S_F);
4842	}
4843
4844	s_return (p);
4845	}	4812	}
4846		4813
4847	case OP_GET_OUTSTRING: /* get-output-string */	4814	case OP_GET_OUTSTRING: /* get-output-string */
4848	{	4815	{
4849	port *p;	4816	port *p;
…		…
4888	case OP_CURR_ENV: /* current-environment */	4855	case OP_CURR_ENV: /* current-environment */
4889	s_return (SCHEME_V->envir);	4856	s_return (SCHEME_V->envir);
4890		4857
4891	}	4858	}
4892		4859
4893	abort ();	4860	if (USE_ERROR_CHECKING) abort ();
4894	}	4861	}
4895		4862
4896	static pointer	4863	static int
4897	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4864	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4898	{	4865	{
		4866	pointer args = SCHEME_V->args;
4899	pointer x;	4867	pointer x;
4900		4868
4901	if (SCHEME_V->nesting != 0)	4869	if (SCHEME_V->nesting != 0)
4902	{	4870	{
4903	int n = SCHEME_V->nesting;	4871	int n = SCHEME_V->nesting;
…		…
4910	switch (op)	4878	switch (op)
4911	{	4879	{
4912	/* ========== reading part ========== */	4880	/* ========== reading part ========== */
4913	#if USE_PORTS	4881	#if USE_PORTS
4914	case OP_READ:	4882	case OP_READ:
4915	if (!is_pair (SCHEME_V->args))	4883	if (!is_pair (args))
4916	s_goto (OP_READ_INTERNAL);	4884	s_goto (OP_READ_INTERNAL);
4917		4885
4918	if (!is_inport (car (SCHEME_V->args)))	4886	if (!is_inport (car (args)))
4919	Error_1 ("read: not an input port:", car (SCHEME_V->args));	4887	Error_1 ("read: not an input port:", car (args));
4920		4888
4921	if (car (SCHEME_V->args) == SCHEME_V->inport)	4889	if (car (args) == SCHEME_V->inport)
4922	s_goto (OP_READ_INTERNAL);	4890	s_goto (OP_READ_INTERNAL);
4923		4891
4924	x = SCHEME_V->inport;	4892	x = SCHEME_V->inport;
4925	SCHEME_V->inport = car (SCHEME_V->args);	4893	SCHEME_V->inport = car (args);
4926	x = cons (x, NIL);	4894	x = cons (x, NIL);
4927	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);	4895	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
4928	s_goto (OP_READ_INTERNAL);	4896	s_goto (OP_READ_INTERNAL);
4929		4897
4930	case OP_READ_CHAR: /* read-char */	4898	case OP_READ_CHAR: /* read-char */
4931	case OP_PEEK_CHAR: /* peek-char */	4899	case OP_PEEK_CHAR: /* peek-char */
4932	{	4900	{
4933	int c;	4901	int c;
4934		4902
4935	if (is_pair (SCHEME_V->args))	4903	if (is_pair (args))
4936	{	4904	{
4937	if (car (SCHEME_V->args) != SCHEME_V->inport)	4905	if (car (args) != SCHEME_V->inport)
4938	{	4906	{
4939	x = SCHEME_V->inport;	4907	x = SCHEME_V->inport;
4940	x = cons (x, NIL);	4908	x = cons (x, NIL);
4941	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);	4909	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
4942	SCHEME_V->inport = car (SCHEME_V->args);	4910	SCHEME_V->inport = car (args);
4943	}	4911	}
4944	}	4912	}
4945		4913
4946	c = inchar (SCHEME_A);	4914	c = inchar (SCHEME_A);
4947		4915
…		…
4957	case OP_CHAR_READY: /* char-ready? */	4925	case OP_CHAR_READY: /* char-ready? */
4958	{	4926	{
4959	pointer p = SCHEME_V->inport;	4927	pointer p = SCHEME_V->inport;
4960	int res;	4928	int res;
4961		4929
4962	if (is_pair (SCHEME_V->args))	4930	if (is_pair (args))
4963	p = car (SCHEME_V->args);	4931	p = car (args);
4964		4932
4965	res = p->object.port->kind & port_string;	4933	res = p->object.port->kind & port_string;
4966		4934
4967	s_retbool (res);	4935	s_retbool (res);
4968	}	4936	}
4969		4937
4970	case OP_SET_INPORT: /* set-input-port */	4938	case OP_SET_INPORT: /* set-input-port */
4971	SCHEME_V->inport = car (SCHEME_V->args);	4939	SCHEME_V->inport = car (args);
4972	s_return (SCHEME_V->value);	4940	s_return (SCHEME_V->value);
4973		4941
4974	case OP_SET_OUTPORT: /* set-output-port */	4942	case OP_SET_OUTPORT: /* set-output-port */
4975	SCHEME_V->outport = car (SCHEME_V->args);	4943	SCHEME_V->outport = car (args);
4976	s_return (SCHEME_V->value);	4944	s_return (SCHEME_V->value);
4977	#endif	4945	#endif
4978		4946
4979	case OP_RDSEXPR:	4947	case OP_RDSEXPR:
4980	switch (SCHEME_V->tok)	4948	switch (SCHEME_V->tok)
…		…
5066	}	5034	}
5067		5035
5068	break;	5036	break;
5069		5037
5070	case OP_RDLIST:	5038	case OP_RDLIST:
5071	SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args);	5039	SCHEME_V->args = cons (SCHEME_V->value, args);
5072	SCHEME_V->tok = token (SCHEME_A);	5040	SCHEME_V->tok = token (SCHEME_A);
5073		5041
5074	switch (SCHEME_V->tok)	5042	switch (SCHEME_V->tok)
5075	{	5043	{
5076	case TOK_EOF:	5044	case TOK_EOF:
…		…
5104	case OP_RDDOT:	5072	case OP_RDDOT:
5105	if (token (SCHEME_A) != TOK_RPAREN)	5073	if (token (SCHEME_A) != TOK_RPAREN)
5106	Error_0 ("syntax error: illegal dot expression");	5074	Error_0 ("syntax error: illegal dot expression");
5107		5075
5108	SCHEME_V->nesting_stack[SCHEME_V->file_i]--;	5076	SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5109	s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args));	5077	s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args));
5110		5078
5111	case OP_RDQUOTE:	5079	case OP_RDQUOTE:
5112	s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));	5080	s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));
5113		5081
5114	case OP_RDQQUOTE:	5082	case OP_RDQQUOTE:
…		…
5136	SCHEME_V->args = SCHEME_V->value;	5104	SCHEME_V->args = SCHEME_V->value;
5137	s_goto (OP_VECTOR);	5105	s_goto (OP_VECTOR);
5138		5106
5139	/* ========== printing part ========== */	5107	/* ========== printing part ========== */
5140	case OP_P0LIST:	5108	case OP_P0LIST:
5141	if (is_vector (SCHEME_V->args))	5109	if (is_vector (args))
5142	{	5110	{
5143	putstr (SCHEME_A_ "#(");	5111	putstr (SCHEME_A_ "#(");
5144	SCHEME_V->args = cons (SCHEME_V->args, mk_integer (SCHEME_A_ 0));	5112	SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0));
5145	s_goto (OP_PVECFROM);	5113	s_goto (OP_PVECFROM);
5146	}	5114	}
5147	else if (is_environment (SCHEME_V->args))	5115	else if (is_environment (args))
5148	{	5116	{
5149	putstr (SCHEME_A_ "#<ENVIRONMENT>");	5117	putstr (SCHEME_A_ "#<ENVIRONMENT>");
5150	s_return (S_T);	5118	s_return (S_T);
5151	}	5119	}
5152	else if (!is_pair (SCHEME_V->args))	5120	else if (!is_pair (args))
5153	{	5121	{
5154	printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag);	5122	printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5155	s_return (S_T);	5123	s_return (S_T);
5156	}	5124	}
5157	else if (car (SCHEME_V->args) == SCHEME_V->QUOTE && ok_abbrev (cdr (SCHEME_V->args)))	5125	else
5158	{	5126	{
		5127	pointer a = car (args);
		5128	pointer b = cdr (args);
		5129	int ok_abbr = ok_abbrev (b);
		5130	SCHEME_V->args = car (b);
		5131
		5132	if (a == SCHEME_V->QUOTE && ok_abbr)
5159	putstr (SCHEME_A_ "'");	5133	putstr (SCHEME_A_ "'");
5160	SCHEME_V->args = cadr (SCHEME_V->args);	5134	else if (a == SCHEME_V->QQUOTE && ok_abbr)
		5135	putstr (SCHEME_A_ "`");
		5136	else if (a == SCHEME_V->UNQUOTE && ok_abbr)
		5137	putstr (SCHEME_A_ ",");
		5138	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
		5139	putstr (SCHEME_A_ ",@");
		5140	else
		5141	{
		5142	putstr (SCHEME_A_ "(");
		5143	s_save (SCHEME_A_ OP_P1LIST, b, NIL);
		5144	SCHEME_V->args = a;
		5145	}
		5146
5161	s_goto (OP_P0LIST);	5147	s_goto (OP_P0LIST);
5162	}	5148	}
5163	else if (car (SCHEME_V->args) == SCHEME_V->QQUOTE && ok_abbrev (cdr (SCHEME_V->args)))	5149
		5150	case OP_P1LIST:
		5151	if (is_pair (args))
5164	{	5152	{
		5153	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5165	putstr (SCHEME_A_ "`");	5154	putstr (SCHEME_A_ " ");
5166	SCHEME_V->args = cadr (SCHEME_V->args);	5155	SCHEME_V->args = car (args);
5167	s_goto (OP_P0LIST);	5156	s_goto (OP_P0LIST);
5168	}	5157	}
5169	else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTE && ok_abbrev (cdr (SCHEME_V->args)))
5170	{
5171	putstr (SCHEME_A_ ",");
5172	SCHEME_V->args = cadr (SCHEME_V->args);
5173	s_goto (OP_P0LIST);
5174	}
5175	else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTESP && ok_abbrev (cdr (SCHEME_V->args)))
5176	{
5177	putstr (SCHEME_A_ ",@");
5178	SCHEME_V->args = cadr (SCHEME_V->args);
5179	s_goto (OP_P0LIST);
5180	}
5181	else
5182	{
5183	putstr (SCHEME_A_ "(");
5184	s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
5185	SCHEME_V->args = car (SCHEME_V->args);
5186	s_goto (OP_P0LIST);
5187	}
5188
5189	case OP_P1LIST:
5190	if (is_pair (SCHEME_V->args))
5191	{
5192	s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
5193	putstr (SCHEME_A_ " ");
5194	SCHEME_V->args = car (SCHEME_V->args);
5195	s_goto (OP_P0LIST);
5196	}
5197	else if (is_vector (SCHEME_V->args))	5158	else if (is_vector (args))
5198	{	5159	{
5199	s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);	5160	s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);
5200	putstr (SCHEME_A_ " . ");	5161	putstr (SCHEME_A_ " . ");
5201	s_goto (OP_P0LIST);	5162	s_goto (OP_P0LIST);
5202	}	5163	}
5203	else	5164	else
5204	{	5165	{
5205	if (SCHEME_V->args != NIL)	5166	if (args != NIL)
5206	{	5167	{
5207	putstr (SCHEME_A_ " . ");	5168	putstr (SCHEME_A_ " . ");
5208	printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag);	5169	printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5209	}	5170	}
5210		5171
5211	putstr (SCHEME_A_ ")");	5172	putstr (SCHEME_A_ ")");
5212	s_return (S_T);	5173	s_return (S_T);
5213	}	5174	}
5214		5175
5215	case OP_PVECFROM:	5176	case OP_PVECFROM:
5216	{	5177	{
5217	int i = ivalue_unchecked (cdr (SCHEME_V->args));	5178	int i = ivalue_unchecked (cdr (args));
5218	pointer vec = car (SCHEME_V->args);	5179	pointer vec = car (args);
5219	int len = veclength (vec);	5180	int len = veclength (vec);
5220		5181
5221	if (i == len)	5182	if (i == len)
5222	{	5183	{
5223	putstr (SCHEME_A_ ")");	5184	putstr (SCHEME_A_ ")");
…		…
5225	}	5186	}
5226	else	5187	else
5227	{	5188	{
5228	pointer elem = vector_elem (vec, i);	5189	pointer elem = vector_elem (vec, i);
5229		5190
5230	ivalue_unchecked (cdr (SCHEME_V->args)) = i + 1;	5191	ivalue_unchecked (cdr (args)) = i + 1;
5231	s_save (SCHEME_A_ OP_PVECFROM, SCHEME_V->args, NIL);	5192	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5232	SCHEME_V->args = elem;	5193	SCHEME_V->args = elem;
5233		5194
5234	if (i > 0)	5195	if (i > 0)
5235	putstr (SCHEME_A_ " ");	5196	putstr (SCHEME_A_ " ");
5236		5197
5237	s_goto (OP_P0LIST);	5198	s_goto (OP_P0LIST);
5238	}	5199	}
5239	}	5200	}
5240	}	5201	}
5241		5202
5242	abort ();	5203	if (USE_ERROR_CHECKING) abort ();
5243	}	5204	}
5244		5205
5245	static pointer	5206	static int
5246	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5207	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5247	{	5208	{
		5209	pointer args = SCHEME_V->args;
		5210	pointer a = car (args);
5248	pointer x, y;	5211	pointer x, y;
5249		5212
5250	switch (op)	5213	switch (op)
5251	{	5214	{
5252	case OP_LIST_LENGTH: /* length *//* a.k */	5215	case OP_LIST_LENGTH: /* length *//* a.k */
5253	{	5216	{
5254	long v = list_length (SCHEME_A_ car (SCHEME_V->args));	5217	long v = list_length (SCHEME_A_ a);
5255		5218
5256	if (v < 0)	5219	if (v < 0)
5257	Error_1 ("length: not a list:", car (SCHEME_V->args));	5220	Error_1 ("length: not a list:", a);
5258		5221
5259	s_return (mk_integer (SCHEME_A_ v));	5222	s_return (mk_integer (SCHEME_A_ v));
5260	}	5223	}
5261		5224
5262	case OP_ASSQ: /* assq *//* a.k */	5225	case OP_ASSQ: /* assq *//* a.k */
5263	x = car (SCHEME_V->args);	5226	x = a;
5264		5227
5265	for (y = cadr (SCHEME_V->args); is_pair (y); y = cdr (y))	5228	for (y = cadr (args); is_pair (y); y = cdr (y))
5266	{	5229	{
5267	if (!is_pair (car (y)))	5230	if (!is_pair (car (y)))
5268	Error_0 ("unable to handle non pair element");	5231	Error_0 ("unable to handle non pair element");
5269		5232
5270	if (x == caar (y))	5233	if (x == caar (y))
…		…
5276	else	5239	else
5277	s_return (S_F);	5240	s_return (S_F);
5278		5241
5279		5242
5280	case OP_GET_CLOSURE: /* get-closure-code *//* a.k */	5243	case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5281	SCHEME_V->args = car (SCHEME_V->args);	5244	SCHEME_V->args = a;
5282		5245
5283	if (SCHEME_V->args == NIL)	5246	if (SCHEME_V->args == NIL)
5284	s_return (S_F);	5247	s_return (S_F);
5285	else if (is_closure (SCHEME_V->args))	5248	else if (is_closure (SCHEME_V->args))
5286	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));	5249	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
…		…
5292	case OP_CLOSUREP: /* closure? */	5255	case OP_CLOSUREP: /* closure? */
5293	/*	5256	/*
5294	* Note, macro object is also a closure.	5257	* Note, macro object is also a closure.
5295	* Therefore, (closure? <#MACRO>) ==> #t	5258	* Therefore, (closure? <#MACRO>) ==> #t
5296	*/	5259	*/
5297	s_retbool (is_closure (car (SCHEME_V->args)));	5260	s_retbool (is_closure (a));
5298		5261
5299	case OP_MACROP: /* macro? */	5262	case OP_MACROP: /* macro? */
5300	s_retbool (is_macro (car (SCHEME_V->args)));	5263	s_retbool (is_macro (a));
5301	}	5264	}
5302		5265
5303	abort ();	5266	if (USE_ERROR_CHECKING) abort ();
5304	}	5267	}
5305		5268
		5269	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5306	typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);	5270	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5307		5271
5308	typedef int (*test_predicate) (pointer);	5272	typedef int (*test_predicate)(pointer);
5309	static int	5273	static int
5310	is_any (pointer p)	5274	is_any (pointer p)
5311	{	5275	{
5312	return 1;	5276	return 1;
5313	}	5277	}
5314		5278
5315	static int	5279	static int
5316	is_nonneg (pointer p)	5280	is_nonneg (pointer p)
5317	{	5281	{
5318	return ivalue (p) >= 0 && is_integer (p);	5282	return ivalue (p) >= 0 && is_integer (p);
		5283	}
		5284
		5285	static int
		5286	tst_is_list (pointer p)
		5287	{
		5288	return p == NIL || is_pair (p);
5319	}	5289	}
5320		5290
5321	/* Correspond carefully with following defines! */	5291	/* Correspond carefully with following defines! */
5322	static struct	5292	static struct
5323	{	5293	{
5324	test_predicate fct;	5294	test_predicate fct;
5325	const char *kind;	5295	const char *kind;
5326	} tests[] =	5296	} tests[] =
5327	{	5297	{
5328	{ 0, 0}, /* unused */	5298	{ is_any, 0 },
5329	{ is_any, 0},	5299	{ is_string, "string" },
5330	{ is_string, "string" },	5300	{ is_symbol, "symbol" },
5331	{ is_symbol, "symbol" },	5301	{ is_port, "port" },
5332	{ is_port, "port" },
5333	{ is_inport, "input port" },	5302	{ is_inport, "input port" },
5334	{ is_outport, "output port" },	5303	{ is_outport, "output port" },
5335	{ is_environment, "environment" },	5304	{ is_environment, "environment" },
5336	{ is_pair, "pair" },	5305	{ is_pair, "pair" },
5337	{ 0, "pair or '()" },	5306	{ tst_is_list, "pair or '()" },
5338	{ is_character, "character" },	5307	{ is_character, "character" },
5339	{ is_vector, "vector" },	5308	{ is_vector, "vector" },
5340	{ is_number, "number" },	5309	{ is_number, "number" },
5341	{ is_integer, "integer" },	5310	{ is_integer, "integer" },
5342	{ is_nonneg, "non-negative integer" }	5311	{ is_nonneg, "non-negative integer" }
5343	};	5312	};
5344		5313
5345	#define TST_NONE 0	5314	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5346	#define TST_ANY "\001"	5315	#define TST_ANY "\001"
5347	#define TST_STRING "\002"	5316	#define TST_STRING "\002"
5348	#define TST_SYMBOL "\003"	5317	#define TST_SYMBOL "\003"
5349	#define TST_PORT "\004"	5318	#define TST_PORT "\004"
5350	#define TST_INPORT "\005"	5319	#define TST_INPORT "\005"
5351	#define TST_OUTPORT "\006"	5320	#define TST_OUTPORT "\006"
5352	#define TST_ENVIRONMENT "\007"	5321	#define TST_ENVIRONMENT "\007"
5353	#define TST_PAIR "\010"	5322	#define TST_PAIR "\010"
5354	#define TST_LIST "\011"	5323	#define TST_LIST "\011"
5355	#define TST_CHAR "\012"	5324	#define TST_CHAR "\012"
5356	#define TST_VECTOR "\013"	5325	#define TST_VECTOR "\013"
5357	#define TST_NUMBER "\014"	5326	#define TST_NUMBER "\014"
5358	#define TST_INTEGER "\015"	5327	#define TST_INTEGER "\015"
5359	#define TST_NATURAL "\016"	5328	#define TST_NATURAL "\016"
		5329
		5330	#define INF_ARG 0xff
		5331	#define UNNAMED_OP ""
		5332
		5333	static const char opnames[] =
		5334	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
		5335	#include "opdefines.h"
		5336	#undef OP_DEF
		5337	;
		5338
		5339	static const char *
		5340	opname (int idx)
		5341	{
		5342	const char *name = opnames;
		5343
		5344	/* should do this at compile time, but would require external program, right? */
		5345	while (idx--)
		5346	name += strlen (name) + 1;
		5347
		5348	return *name ? name : "ILLEGAL";
		5349	}
		5350
		5351	static const char *
		5352	procname (pointer x)
		5353	{
		5354	return opname (procnum (x));
		5355	}
5360		5356
5361	typedef struct	5357	typedef struct
5362	{	5358	{
5363	dispatch_func func;	5359	uint8_t func;
5364	char *name;	5360	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
		5361	uint8_t builtin;
5365	int min_arity;	5362	uint8_t min_arity;
5366	int max_arity;	5363	uint8_t max_arity;
5367	char *arg_tests_encoding;	5364	char arg_tests_encoding[3];
5368	} op_code_info;	5365	} op_code_info;
5369		5366
5370	#define INF_ARG 0xffff
5371
5372	static op_code_info dispatch_table[] = {	5367	static const op_code_info dispatch_table[] = {
5373	#define OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},	5368	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
5374	#include "opdefines.h"	5369	#include "opdefines.h"
		5370	#undef OP_DEF
5375	{0}	5371	{0}
5376	};	5372	};
5377		5373
5378	static const char *
5379	procname (pointer x)
5380	{
5381	int n = procnum (x);
5382	const char *name = dispatch_table[n].name;
5383
5384	if (name == 0)
5385	name = "ILLEGAL!";
5386
5387	return name;
5388	}
5389
5390	/* kernel of this interpreter */	5374	/* kernel of this interpreter */
5391	static void	5375	static void ecb_hot
5392	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5376	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5393	{	5377	{
5394	SCHEME_V->op = op;	5378	SCHEME_V->op = op;
5395		5379
5396	for (;;)	5380	for (;;)
5397	{	5381	{
5398	op_code_info *pcd = dispatch_table + SCHEME_V->op;	5382	const op_code_info *pcd = dispatch_table + SCHEME_V->op;
5399		5383
5400	#if USE_ERROR_CHECKING	5384	#if USE_ERROR_CHECKING
5401	if (pcd->name) /* if built-in function, check arguments */	5385	if (pcd->builtin) /* if built-in function, check arguments */
5402	{	5386	{
5403	int ok = 1;
5404	char msg[STRBUFFSIZE];	5387	char msg[STRBUFFSIZE];
5405	int n = list_length (SCHEME_A_ SCHEME_V->args);	5388	int n = list_length (SCHEME_A_ SCHEME_V->args);
5406		5389
5407	/* Check number of arguments */	5390	/* Check number of arguments */
5408	if (ecb_expect_false (n < pcd->min_arity))	5391	if (ecb_expect_false (n < pcd->min_arity))
5409	{	5392	{
5410	ok = 0;
5411	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5393	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5412	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);	5394	opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
		5395	xError_1 (SCHEME_A_ msg, 0);
		5396	continue;
5413	}	5397	}
5414	else if (ecb_expect_false (n > pcd->max_arity))	5398	else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
5415	{	5399	{
5416	ok = 0;
5417	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5400	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5418	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);	5401	opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
		5402	xError_1 (SCHEME_A_ msg, 0);
		5403	continue;
5419	}	5404	}
5420		5405	else
5421	if (ecb_expect_false (ok))
5422	{	5406	{
5423	if (pcd->arg_tests_encoding)	5407	if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */
5424	{	5408	{
5425	int i = 0;	5409	int i = 0;
5426	int j;	5410	int j;
5427	const char *t = pcd->arg_tests_encoding;	5411	const char *t = pcd->arg_tests_encoding;
5428	pointer arglist = SCHEME_V->args;	5412	pointer arglist = SCHEME_V->args;
5429		5413
5430	do	5414	do
5431	{	5415	{
5432	pointer arg = car (arglist);	5416	pointer arg = car (arglist);
5433		5417
5434	j = (int) t[0];	5418	j = t[0];
5435		5419
5436	if (j == TST_LIST[0])	5420	if (!tests[j - 1].fct (arg))
5437	{
5438	if (arg != NIL && !is_pair (arg))
5439	break;	5421	break;
5440	}
5441	else
5442	{
5443	if (!tests[j].fct (arg))
5444	break;
5445	}
5446		5422
5447	if (t[1] != 0) /* last test is replicated as necessary */	5423	if (t[1]) /* last test is replicated as necessary */
5448	t++;	5424	t++;
5449		5425
5450	arglist = cdr (arglist);	5426	arglist = cdr (arglist);
5451	i++;	5427	i++;
5452	}	5428	}
5453	while (i < n);	5429	while (i < n);
5454		5430
5455	if (i < n)	5431	if (i < n)
5456	{	5432	{
5457	ok = 0;
5458	snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind);	5433	snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind);
		5434	xError_1 (SCHEME_A_ msg, 0);
		5435	continue;
5459	}	5436	}
5460	}	5437	}
5461	}	5438	}
5462
5463	if (!ok)
5464	{
5465	if (xError_1 (SCHEME_A_ msg, 0) == NIL)
5466	return;
5467
5468	pcd = dispatch_table + SCHEME_V->op;
5469	}
5470	}	5439	}
5471	#endif	5440	#endif
5472		5441
5473	ok_to_freely_gc (SCHEME_A);	5442	ok_to_freely_gc (SCHEME_A);
5474		5443
		5444	static const dispatch_func dispatch_funcs[] = {
		5445	opexe_0,
		5446	opexe_1,
		5447	opexe_2,
		5448	opexe_3,
		5449	opexe_4,
		5450	opexe_5,
		5451	opexe_6,
		5452	};
		5453
5475	if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))	5454	if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5476	return;	5455	return;
5477		5456
5478	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	5457	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5479	{	5458	{
5480	xwrstr ("No memory!\n");	5459	xwrstr ("No memory!\n");
…		…
5579	return OP_C0STREAM; /* cons-stream */	5558	return OP_C0STREAM; /* cons-stream */
5580	}	5559	}
5581	}	5560	}
5582		5561
5583	#if USE_MULTIPLICITY	5562	#if USE_MULTIPLICITY
5584	scheme *	5563	ecb_cold scheme *
5585	scheme_init_new ()	5564	scheme_init_new ()
5586	{	5565	{
5587	scheme *sc = malloc (sizeof (scheme));	5566	scheme *sc = malloc (sizeof (scheme));
5588		5567
5589	if (!scheme_init (SCHEME_A))	5568	if (!scheme_init (SCHEME_A))
…		…
5594	else	5573	else
5595	return sc;	5574	return sc;
5596	}	5575	}
5597	#endif	5576	#endif
5598		5577
5599	int	5578	ecb_cold int
5600	scheme_init (SCHEME_P)	5579	scheme_init (SCHEME_P)
5601	{	5580	{
5602	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	5581	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5603	pointer x;	5582	pointer x;
5604		5583
…		…
5677		5656
5678	for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)	5657	for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
5679	assign_syntax (SCHEME_A_ syntax_names[i]);	5658	assign_syntax (SCHEME_A_ syntax_names[i]);
5680	}	5659	}
5681		5660
		5661	// TODO: should iterate via strlen, to avoid n² complexity
5682	for (i = 0; i < n; i++)	5662	for (i = 0; i < n; i++)
5683	if (dispatch_table[i].name != 0)	5663	if (dispatch_table[i].builtin)
5684	assign_proc (SCHEME_A_ i, dispatch_table[i].name);	5664	assign_proc (SCHEME_A_ i, opname (i));
5685		5665
5686	/* initialization of global pointers to special symbols */	5666	/* initialization of global pointers to special symbols */
5687	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");	5667	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5688	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");	5668	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5689	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");	5669	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
…		…
5728	scheme_set_external_data (SCHEME_P_ void *p)	5708	scheme_set_external_data (SCHEME_P_ void *p)
5729	{	5709	{
5730	SCHEME_V->ext_data = p;	5710	SCHEME_V->ext_data = p;
5731	}	5711	}
5732		5712
5733	void	5713	ecb_cold void
5734	scheme_deinit (SCHEME_P)	5714	scheme_deinit (SCHEME_P)
5735	{	5715	{
5736	int i;	5716	int i;
5737		5717
5738	#if SHOW_ERROR_LINE	5718	#if SHOW_ERROR_LINE
…		…
5830	{	5810	{
5831	dump_stack_reset (SCHEME_A);	5811	dump_stack_reset (SCHEME_A);
5832	SCHEME_V->envir = SCHEME_V->global_env;	5812	SCHEME_V->envir = SCHEME_V->global_env;
5833	SCHEME_V->file_i = 0;	5813	SCHEME_V->file_i = 0;
5834	SCHEME_V->load_stack[0].kind = port_input | port_string;	5814	SCHEME_V->load_stack[0].kind = port_input | port_string;
5835	SCHEME_V->load_stack[0].rep.string.start = (char *) cmd; /* This func respects const */	5815	SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5836	SCHEME_V->load_stack[0].rep.string.past_the_end = (char *) cmd + strlen (cmd);	5816	SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5837	SCHEME_V->load_stack[0].rep.string.curr = (char *) cmd;	5817	SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5838	#if USE_PORTS	5818	#if USE_PORTS
5839	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);	5819	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5840	#endif	5820	#endif
5841	SCHEME_V->retcode = 0;	5821	SCHEME_V->retcode = 0;
5842	SCHEME_V->interactive_repl = 0;	5822	SCHEME_V->interactive_repl = 0;

Diff Legend

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