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.24 by root, Fri Nov 27 02:12:08 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	224	ecb_inline int
229	num_is_integer (pointer p)	225	num_is_integer (pointer p)
230	{	226	{
231	return num_is_fixnum (p->object.number);	227	return num_is_fixnum (p->object.number);
232	}	228	}
233		229
…		…
237	/* macros for cell operations */	233	/* macros for cell operations */
238	#define typeflag(p) ((p)->flag + 0)	234	#define typeflag(p) ((p)->flag + 0)
239	#define set_typeflag(p,v) ((p)->flag = (v))	235	#define set_typeflag(p,v) ((p)->flag = (v))
240	#define type(p) (typeflag (p) & T_MASKTYPE)	236	#define type(p) (typeflag (p) & T_MASKTYPE)
241		237
242	INTERFACE INLINE int	238	INTERFACE int
243	is_string (pointer p)	239	is_string (pointer p)
244	{	240	{
245	return type (p) == T_STRING;	241	return type (p) == T_STRING;
246	}	242	}
247		243
248	#define strvalue(p) ((p)->object.string.svalue)	244	#define strvalue(p) ((p)->object.string.svalue)
249	#define strlength(p) ((p)->object.string.length)	245	#define strlength(p) ((p)->object.string.length)
250		246
251	INTERFACE int is_list (SCHEME_P_ pointer p);	247	INTERFACE int is_list (SCHEME_P_ pointer p);
		248
252	INTERFACE INLINE int	249	INTERFACE int
253	is_vector (pointer p)	250	is_vector (pointer p)
254	{	251	{
255	return type (p) == T_VECTOR;	252	return type (p) == T_VECTOR;
256	}	253	}
257		254
…		…
266	vector_length (pointer vec)	263	vector_length (pointer vec)
267	{	264	{
268	return vec->object.vector.length;	265	return vec->object.vector.length;
269	}	266	}
270		267
271	INTERFACE INLINE int	268	INTERFACE int
272	is_number (pointer p)	269	is_number (pointer p)
273	{	270	{
274	return type (p) == T_NUMBER;	271	return type (p) == T_NUMBER;
275	}	272	}
276		273
277	INTERFACE INLINE int	274	INTERFACE int
278	is_integer (pointer p)	275	is_integer (pointer p)
279	{	276	{
280	if (!is_number (p))	277	if (!is_number (p))
281	return 0;	278	return 0;
282		279
…		…
284	return 1;	281	return 1;
285		282
286	return 0;	283	return 0;
287	}	284	}
288		285
289	INTERFACE INLINE int	286	INTERFACE int
290	is_real (pointer p)	287	is_real (pointer p)
291	{	288	{
292	return is_number (p) && !num_is_fixnum (p->object.number);	289	return is_number (p) && !num_is_fixnum (p->object.number);
293	}	290	}
294		291
295	INTERFACE INLINE int	292	INTERFACE int
296	is_character (pointer p)	293	is_character (pointer p)
297	{	294	{
298	return type (p) == T_CHARACTER;	295	return type (p) == T_CHARACTER;
299	}	296	}
300		297
301	INTERFACE INLINE char *	298	INTERFACE char *
302	string_value (pointer p)	299	string_value (pointer p)
303	{	300	{
304	return strvalue (p);	301	return strvalue (p);
305	}	302	}
306		303
307	INLINE num	304	ecb_inline num
308	nvalue (pointer p)	305	nvalue (pointer p)
309	{	306	{
310	return (p)->object.number;	307	return (p)->object.number;
311	}	308	}
312		309
…		…
342	#else	339	#else
343	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)	340	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
344	# define set_num_integer(p) 0	341	# define set_num_integer(p) 0
345	# define set_num_real(p) 0	342	# define set_num_real(p) 0
346	#endif	343	#endif
		344
347	INTERFACE long	345	INTERFACE long
348	charvalue (pointer p)	346	charvalue (pointer p)
349	{	347	{
350	return ivalue_unchecked (p);	348	return ivalue_unchecked (p);
351	}	349	}
352		350
353	INTERFACE INLINE int	351	INTERFACE int
354	is_port (pointer p)	352	is_port (pointer p)
355	{	353	{
356	return type (p) == T_PORT;	354	return type (p) == T_PORT;
357	}	355	}
358		356
359	INTERFACE INLINE int	357	INTERFACE int
360	is_inport (pointer p)	358	is_inport (pointer p)
361	{	359	{
362	return is_port (p) && p->object.port->kind & port_input;	360	return is_port (p) && p->object.port->kind & port_input;
363	}	361	}
364		362
365	INTERFACE INLINE int	363	INTERFACE int
366	is_outport (pointer p)	364	is_outport (pointer p)
367	{	365	{
368	return is_port (p) && p->object.port->kind & port_output;	366	return is_port (p) && p->object.port->kind & port_output;
369	}	367	}
370		368
371	INTERFACE INLINE int	369	INTERFACE int
372	is_pair (pointer p)	370	is_pair (pointer p)
373	{	371	{
374	return type (p) == T_PAIR;	372	return type (p) == T_PAIR;
375	}	373	}
376		374
…		…
408	pair_cdr (pointer p)	406	pair_cdr (pointer p)
409	{	407	{
410	return cdr (p);	408	return cdr (p);
411	}	409	}
412		410
413	INTERFACE INLINE int	411	INTERFACE int
414	is_symbol (pointer p)	412	is_symbol (pointer p)
415	{	413	{
416	return type (p) == T_SYMBOL;	414	return type (p) == T_SYMBOL;
417	}	415	}
418		416
419	INTERFACE INLINE char *	417	INTERFACE char *
420	symname (pointer p)	418	symname (pointer p)
421	{	419	{
422	return strvalue (car (p));	420	return strvalue (car (p));
423	}	421	}
424		422
425	#if USE_PLIST	423	#if USE_PLIST
426	SCHEME_EXPORT INLINE int	424	SCHEME_EXPORT int
427	hasprop (pointer p)	425	hasprop (pointer p)
428	{	426	{
429	return typeflag (p) & T_SYMBOL;	427	return typeflag (p) & T_SYMBOL;
430	}	428	}
431		429
432	# define symprop(p) cdr(p)	430	# define symprop(p) cdr(p)
433	#endif	431	#endif
434		432
435	INTERFACE INLINE int	433	INTERFACE int
436	is_syntax (pointer p)	434	is_syntax (pointer p)
437	{	435	{
438	return typeflag (p) & T_SYNTAX;	436	return typeflag (p) & T_SYNTAX;
439	}	437	}
440		438
441	INTERFACE INLINE int	439	INTERFACE int
442	is_proc (pointer p)	440	is_proc (pointer p)
443	{	441	{
444	return type (p) == T_PROC;	442	return type (p) == T_PROC;
445	}	443	}
446		444
447	INTERFACE INLINE int	445	INTERFACE int
448	is_foreign (pointer p)	446	is_foreign (pointer p)
449	{	447	{
450	return type (p) == T_FOREIGN;	448	return type (p) == T_FOREIGN;
451	}	449	}
452		450
453	INTERFACE INLINE char *	451	INTERFACE char *
454	syntaxname (pointer p)	452	syntaxname (pointer p)
455	{	453	{
456	return strvalue (car (p));	454	return strvalue (car (p));
457	}	455	}
458		456
459	#define procnum(p) ivalue (p)	457	#define procnum(p) ivalue (p)
460	static const char *procname (pointer x);	458	static const char *procname (pointer x);
461		459
462	INTERFACE INLINE int	460	INTERFACE int
463	is_closure (pointer p)	461	is_closure (pointer p)
464	{	462	{
465	return type (p) == T_CLOSURE;	463	return type (p) == T_CLOSURE;
466	}	464	}
467		465
468	INTERFACE INLINE int	466	INTERFACE int
469	is_macro (pointer p)	467	is_macro (pointer p)
470	{	468	{
471	return type (p) == T_MACRO;	469	return type (p) == T_MACRO;
472	}	470	}
473		471
474	INTERFACE INLINE pointer	472	INTERFACE pointer
475	closure_code (pointer p)	473	closure_code (pointer p)
476	{	474	{
477	return car (p);	475	return car (p);
478	}	476	}
479		477
480	INTERFACE INLINE pointer	478	INTERFACE pointer
481	closure_env (pointer p)	479	closure_env (pointer p)
482	{	480	{
483	return cdr (p);	481	return cdr (p);
484	}	482	}
485		483
486	INTERFACE INLINE int	484	INTERFACE int
487	is_continuation (pointer p)	485	is_continuation (pointer p)
488	{	486	{
489	return type (p) == T_CONTINUATION;	487	return type (p) == T_CONTINUATION;
490	}	488	}
491		489
492	#define cont_dump(p) cdr (p)	490	#define cont_dump(p) cdr (p)
493	#define set_cont_dump(p,v) set_cdr ((p), (v))	491	#define set_cont_dump(p,v) set_cdr ((p), (v))
494		492
495	/* To do: promise should be forced ONCE only */	493	/* To do: promise should be forced ONCE only */
496	INTERFACE INLINE int	494	INTERFACE int
497	is_promise (pointer p)	495	is_promise (pointer p)
498	{	496	{
499	return type (p) == T_PROMISE;	497	return type (p) == T_PROMISE;
500	}	498	}
501		499
502	INTERFACE INLINE int	500	INTERFACE int
503	is_environment (pointer p)	501	is_environment (pointer p)
504	{	502	{
505	return type (p) == T_ENVIRONMENT;	503	return type (p) == T_ENVIRONMENT;
506	}	504	}
507		505
…		…
513		511
514	#define is_mark(p) (typeflag (p) & T_MARK)	512	#define is_mark(p) (typeflag (p) & T_MARK)
515	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)	513	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
516	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	514	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
517		515
518	INTERFACE INLINE int	516	INTERFACE int
519	is_immutable (pointer p)	517	is_immutable (pointer p)
520	{	518	{
521	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	519	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
522	}	520	}
523		521
524	INTERFACE INLINE void	522	INTERFACE void
525	setimmutable (pointer p)	523	setimmutable (pointer p)
526	{	524	{
527	#if USE_ERROR_CHECKING	525	#if USE_ERROR_CHECKING
528	set_typeflag (p, typeflag (p) | T_IMMUTABLE);	526	set_typeflag (p, typeflag (p) | T_IMMUTABLE);
529	#endif	527	#endif
530	}	528	}
531		529
532	#if USE_CHAR_CLASSIFIERS	530	#if USE_CHAR_CLASSIFIERS
533	static INLINE int	531	ecb_inline int
534	Cisalpha (int c)	532	Cisalpha (int c)
535	{	533	{
536	return isascii (c) && isalpha (c);	534	return isascii (c) && isalpha (c);
537	}	535	}
538		536
539	static INLINE int	537	ecb_inline int
540	Cisdigit (int c)	538	Cisdigit (int c)
541	{	539	{
542	return isascii (c) && isdigit (c);	540	return isascii (c) && isdigit (c);
543	}	541	}
544		542
545	static INLINE int	543	ecb_inline int
546	Cisspace (int c)	544	Cisspace (int c)
547	{	545	{
548	return isascii (c) && isspace (c);	546	return isascii (c) && isspace (c);
549	}	547	}
550		548
551	static INLINE int	549	ecb_inline int
552	Cisupper (int c)	550	Cisupper (int c)
553	{	551	{
554	return isascii (c) && isupper (c);	552	return isascii (c) && isupper (c);
555	}	553	}
556		554
557	static INLINE int	555	ecb_inline int
558	Cislower (int c)	556	Cislower (int c)
559	{	557	{
560	return isascii (c) && islower (c);	558	return isascii (c) && islower (c);
561	}	559	}
562	#endif	560	#endif
…		…
623	#endif	621	#endif
624		622
625	static int file_push (SCHEME_P_ const char *fname);	623	static int file_push (SCHEME_P_ const char *fname);
626	static void file_pop (SCHEME_P);	624	static void file_pop (SCHEME_P);
627	static int file_interactive (SCHEME_P);	625	static int file_interactive (SCHEME_P);
628	static INLINE int is_one_of (char *s, int c);	626	ecb_inline int is_one_of (char *s, int c);
629	static int alloc_cellseg (SCHEME_P_ int n);	627	static int alloc_cellseg (SCHEME_P_ int n);
630	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);	628	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
631	static void finalize_cell (SCHEME_P_ pointer a);	629	static void finalize_cell (SCHEME_P_ pointer a);
632	static int count_consecutive_cells (pointer x, int needed);	630	static int count_consecutive_cells (pointer x, int needed);
633	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	631	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
634	static pointer mk_number (SCHEME_P_ const num n);	632	static pointer mk_number (SCHEME_P_ const num n);
635	static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);	633	static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
…		…
652	static int basic_inchar (port *pt);	650	static int basic_inchar (port *pt);
653	static int inchar (SCHEME_P);	651	static int inchar (SCHEME_P);
654	static void backchar (SCHEME_P_ int c);	652	static void backchar (SCHEME_P_ int c);
655	static char *readstr_upto (SCHEME_P_ char *delim);	653	static char *readstr_upto (SCHEME_P_ char *delim);
656	static pointer readstrexp (SCHEME_P);	654	static pointer readstrexp (SCHEME_P);
657	static INLINE int skipspace (SCHEME_P);	655	ecb_inline int skipspace (SCHEME_P);
658	static int token (SCHEME_P);	656	static int token (SCHEME_P);
659	static void printslashstring (SCHEME_P_ char *s, int len);	657	static void printslashstring (SCHEME_P_ char *s, int len);
660	static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);	658	static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
661	static void printatom (SCHEME_P_ pointer l, int f);	659	static void printatom (SCHEME_P_ pointer l, int f);
662	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	660	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
666	static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);	664	static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
667	static pointer revappend (SCHEME_P_ pointer a, pointer b);	665	static pointer revappend (SCHEME_P_ pointer a, pointer b);
668	static pointer ss_get_cont (SCHEME_P);	666	static pointer ss_get_cont (SCHEME_P);
669	static void ss_set_cont (SCHEME_P_ pointer cont);	667	static void ss_set_cont (SCHEME_P_ pointer cont);
670	static void dump_stack_mark (SCHEME_P);	668	static void dump_stack_mark (SCHEME_P);
671	static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op);	669	static int opexe_0 (SCHEME_P_ enum scheme_opcodes op);
		670	static int opexe_1 (SCHEME_P_ enum scheme_opcodes op);
672	static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op);	671	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);	672	static int opexe_3 (SCHEME_P_ enum scheme_opcodes op);
675	static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);	673	static int opexe_4 (SCHEME_P_ enum scheme_opcodes op);
676	static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);	674	static int opexe_5 (SCHEME_P_ enum scheme_opcodes op);
677	static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);	675	static int opexe_6 (SCHEME_P_ enum scheme_opcodes op);
678	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);	676	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
679	static void assign_syntax (SCHEME_P_ const char *name);	677	static void assign_syntax (SCHEME_P_ const char *name);
680	static int syntaxnum (pointer p);	678	static int syntaxnum (pointer p);
681	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);	679	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
682		680
…		…
780		778
781	num_set_ivalue (ret, res);	779	num_set_ivalue (ret, res);
782	return ret;	780	return ret;
783	}	781	}
784		782
785	/* this completely disrespects NaNs */	783	/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
786	static int	784	static int
787	num_cmp (num a, num b)	785	num_cmp (num a, num b)
788	{	786	{
789	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);	787	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
790	int ret;	788	int ret;
…		…
833	#endif	831	#endif
834		832
835	static int	833	static int
836	is_zero_rvalue (RVALUE x)	834	is_zero_rvalue (RVALUE x)
837	{	835	{
		836	return x == 0;
		837	#if 0
838	#if USE_REAL	838	#if USE_REAL
839	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */	839	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
840	#else	840	#else
841	return x == 0;	841	return x == 0;
		842	#endif
842	#endif	843	#endif
843	}	844	}
844		845
845	/* allocate new cell segment */	846	/* allocate new cell segment */
846	static int	847	static int
…		…
918		919
919	return n;	920	return n;
920	}	921	}
921		922
922	/* get new cell. parameter a, b is marked by gc. */	923	/* get new cell. parameter a, b is marked by gc. */
923	static INLINE pointer	924	ecb_inline pointer
924	get_cell_x (SCHEME_P_ pointer a, pointer b)	925	get_cell_x (SCHEME_P_ pointer a, pointer b)
925	{	926	{
926	if (ecb_expect_false (SCHEME_V->free_cell == NIL))	927	if (ecb_expect_false (SCHEME_V->free_cell == NIL))
927	{	928	{
928	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	929	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
…		…
1006	push_recent_alloc (SCHEME_A_ v, NIL);	1007	push_recent_alloc (SCHEME_A_ v, NIL);
1007		1008
1008	return v;	1009	return v;
1009	}	1010	}
1010		1011
1011	static INLINE void	1012	ecb_inline void
1012	ok_to_freely_gc (SCHEME_P)	1013	ok_to_freely_gc (SCHEME_P)
1013	{	1014	{
1014	set_car (S_SINK, NIL);	1015	set_car (S_SINK, NIL);
1015	}	1016	}
1016		1017
…		…
1080	location = hash_fn (name, veclength (SCHEME_V->oblist));	1081	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)));	1082	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1082	return x;	1083	return x;
1083	}	1084	}
1084		1085
1085	static INLINE pointer	1086	ecb_inline pointer
1086	oblist_find_by_name (SCHEME_P_ const char *name)	1087	oblist_find_by_name (SCHEME_P_ const char *name)
1087	{	1088	{
1088	int location;	1089	int location;
1089	pointer x;	1090	pointer x;
1090	char *s;	1091	char *s;
…		…
1123	oblist_initial_value (SCHEME_P)	1124	oblist_initial_value (SCHEME_P)
1124	{	1125	{
1125	return NIL;	1126	return NIL;
1126	}	1127	}
1127		1128
1128	static INLINE pointer	1129	ecb_inline pointer
1129	oblist_find_by_name (SCHEME_P_ const char *name)	1130	oblist_find_by_name (SCHEME_P_ const char *name)
1130	{	1131	{
1131	pointer x;	1132	pointer x;
1132	char *s;	1133	char *s;
1133		1134
…		…
2231	}	2232	}
2232	}	2233	}
2233	}	2234	}
2234		2235
2235	/* check c is in chars */	2236	/* check c is in chars */
2236	static INLINE int	2237	ecb_inline int
2237	is_one_of (char *s, int c)	2238	is_one_of (char *s, int c)
2238	{	2239	{
2239	if (c == EOF)	2240	if (c == EOF)
2240	return 1;	2241	return 1;
2241		2242
2242	return !!strchr (s, c);	2243	return !!strchr (s, c);
2243	}	2244	}
2244		2245
2245	/* skip white characters */	2246	/* skip white characters */
2246	static INLINE int	2247	ecb_inline int
2247	skipspace (SCHEME_P)	2248	skipspace (SCHEME_P)
2248	{	2249	{
2249	int c, curr_line = 0;	2250	int c, curr_line = 0;
2250		2251
2251	do	2252	do
…		…
2822		2823
2823	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2824	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2824	setenvironment (SCHEME_V->envir);	2825	setenvironment (SCHEME_V->envir);
2825	}	2826	}
2826		2827
2827	static INLINE void	2828	ecb_inline void
2828	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2829	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2829	{	2830	{
2830	pointer slot = immutable_cons (variable, value);	2831	pointer slot = immutable_cons (variable, value);
2831		2832
2832	if (is_vector (car (env)))	2833	if (is_vector (car (env)))
…		…
2872	return NIL;	2873	return NIL;
2873	}	2874	}
2874		2875
2875	#else /* USE_ALIST_ENV */	2876	#else /* USE_ALIST_ENV */
2876		2877
2877	static INLINE void	2878	ecb_inline void
2878	new_frame_in_env (SCHEME_P_ pointer old_env)	2879	new_frame_in_env (SCHEME_P_ pointer old_env)
2879	{	2880	{
2880	SCHEME_V->envir = immutable_cons (NIL, old_env);	2881	SCHEME_V->envir = immutable_cons (NIL, old_env);
2881	setenvironment (SCHEME_V->envir);	2882	setenvironment (SCHEME_V->envir);
2882	}	2883	}
2883		2884
2884	static INLINE void	2885	ecb_inline void
2885	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2886	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2886	{	2887	{
2887	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2888	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2888	}	2889	}
2889		2890
…		…
2911	return NIL;	2912	return NIL;
2912	}	2913	}
2913		2914
2914	#endif /* USE_ALIST_ENV else */	2915	#endif /* USE_ALIST_ENV else */
2915		2916
2916	static INLINE void	2917	ecb_inline void
2917	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2918	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2918	{	2919	{
2919	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);	2920	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2920	}	2921	}
2921		2922
2922	static INLINE void	2923	ecb_inline void
2923	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2924	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2924	{	2925	{
2925	set_cdr (slot, value);	2926	set_cdr (slot, value);
2926	}	2927	}
2927		2928
2928	static INLINE pointer	2929	ecb_inline pointer
2929	slot_value_in_env (pointer slot)	2930	slot_value_in_env (pointer slot)
2930	{	2931	{
2931	return cdr (slot);	2932	return cdr (slot);
2932	}	2933	}
2933		2934
2934	/* ========== Evaluation Cycle ========== */	2935	/* ========== Evaluation Cycle ========== */
2935		2936
2936	static pointer	2937	static int
2937	xError_1 (SCHEME_P_ const char *s, pointer a)	2938	xError_1 (SCHEME_P_ const char *s, pointer a)
2938	{	2939	{
2939	#if USE_ERROR_HOOK	2940	#if USE_ERROR_HOOK
2940	pointer x;	2941	pointer x;
2941	pointer hdl = SCHEME_V->ERROR_HOOK;	2942	pointer hdl = SCHEME_V->ERROR_HOOK;
…		…
2976	code = cons (mk_string (SCHEME_A_ s), code);	2977	code = cons (mk_string (SCHEME_A_ s), code);
2977	setimmutable (car (code));	2978	setimmutable (car (code));
2978	SCHEME_V->code = cons (slot_value_in_env (x), code);	2979	SCHEME_V->code = cons (slot_value_in_env (x), code);
2979	SCHEME_V->op = OP_EVAL;	2980	SCHEME_V->op = OP_EVAL;
2980		2981
2981	return S_T;	2982	return 0;
2982	}	2983	}
2983	#endif	2984	#endif
2984		2985
2985	if (a)	2986	if (a)
2986	SCHEME_V->args = cons (a, NIL);	2987	SCHEME_V->args = cons (a, NIL);
…		…
2988	SCHEME_V->args = NIL;	2989	SCHEME_V->args = NIL;
2989		2990
2990	SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);	2991	SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
2991	setimmutable (car (SCHEME_V->args));	2992	setimmutable (car (SCHEME_V->args));
2992	SCHEME_V->op = OP_ERR0;	2993	SCHEME_V->op = OP_ERR0;
		2994
2993	return S_T;	2995	return 0;
2994	}	2996	}
2995		2997
2996	#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)	2998	#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
2997	#define Error_0(s) Error_1 (s, 0)	2999	#define Error_0(s) Error_1 (s, 0)
2998		3000
2999	/* Too small to turn into function */	3001	/* Too small to turn into function */
3000	#define BEGIN do {	3002	#define BEGIN do {
3001	#define END } while (0)	3003	#define END } while (0)
3002	#define s_goto(a) BEGIN \	3004	#define s_goto(a) BEGIN \
3003	SCHEME_V->op = a; \	3005	SCHEME_V->op = a; \
3004	return S_T; END	3006	return 0; END
3005		3007
3006	#define s_return(a) return xs_return (SCHEME_A_ a)	3008	#define s_return(a) return xs_return (SCHEME_A_ a)
3007		3009
3008	#ifndef USE_SCHEME_STACK	3010	#ifndef USE_SCHEME_STACK
3009		3011
…		…
3039	next_frame->code = code;	3041	next_frame->code = code;
3040		3042
3041	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3043	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3042	}	3044	}
3043		3045
3044	static pointer	3046	static int
3045	xs_return (SCHEME_P_ pointer a)	3047	xs_return (SCHEME_P_ pointer a)
3046	{	3048	{
3047	int nframes = (uintptr_t)SCHEME_V->dump;	3049	int nframes = (uintptr_t)SCHEME_V->dump;
3048	struct dump_stack_frame *frame;	3050	struct dump_stack_frame *frame;
3049		3051
3050	SCHEME_V->value = a;	3052	SCHEME_V->value = a;
3051		3053
3052	if (nframes <= 0)	3054	if (nframes <= 0)
3053	return NIL;	3055	return -1;
3054		3056
3055	frame = &SCHEME_V->dump_base[--nframes];	3057	frame = &SCHEME_V->dump_base[--nframes];
3056	SCHEME_V->op = frame->op;	3058	SCHEME_V->op = frame->op;
3057	SCHEME_V->args = frame->args;	3059	SCHEME_V->args = frame->args;
3058	SCHEME_V->envir = frame->envir;	3060	SCHEME_V->envir = frame->envir;
3059	SCHEME_V->code = frame->code;	3061	SCHEME_V->code = frame->code;
3060	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3062	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3061		3063
3062	return S_T;	3064	return 0;
3063	}	3065	}
3064		3066
3065	static INLINE void	3067	ecb_inline void
3066	dump_stack_reset (SCHEME_P)	3068	dump_stack_reset (SCHEME_P)
3067	{	3069	{
3068	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */	3070	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3069	SCHEME_V->dump = (pointer)+0;	3071	SCHEME_V->dump = (pointer)+0;
3070	}	3072	}
3071		3073
3072	static INLINE void	3074	ecb_inline void
3073	dump_stack_initialize (SCHEME_P)	3075	dump_stack_initialize (SCHEME_P)
3074	{	3076	{
3075	SCHEME_V->dump_size = 0;	3077	SCHEME_V->dump_size = 0;
3076	SCHEME_V->dump_base = 0;	3078	SCHEME_V->dump_base = 0;
3077	dump_stack_reset (SCHEME_A);	3079	dump_stack_reset (SCHEME_A);
…		…
3144	SCHEME_V->dump = (pointer)(uintptr_t)i;	3146	SCHEME_V->dump = (pointer)(uintptr_t)i;
3145	}	3147	}
3146		3148
3147	#else	3149	#else
3148		3150
3149	static INLINE void	3151	ecb_inline void
3150	dump_stack_reset (SCHEME_P)	3152	dump_stack_reset (SCHEME_P)
3151	{	3153	{
3152	SCHEME_V->dump = NIL;	3154	SCHEME_V->dump = NIL;
3153	}	3155	}
3154		3156
3155	static INLINE void	3157	ecb_inline void
3156	dump_stack_initialize (SCHEME_P)	3158	dump_stack_initialize (SCHEME_P)
3157	{	3159	{
3158	dump_stack_reset (SCHEME_A);	3160	dump_stack_reset (SCHEME_A);
3159	}	3161	}
3160		3162
…		…
3162	dump_stack_free (SCHEME_P)	3164	dump_stack_free (SCHEME_P)
3163	{	3165	{
3164	SCHEME_V->dump = NIL;	3166	SCHEME_V->dump = NIL;
3165	}	3167	}
3166		3168
3167	static pointer	3169	static int
3168	xs_return (SCHEME_P_ pointer a)	3170	xs_return (SCHEME_P_ pointer a)
3169	{	3171	{
3170	pointer dump = SCHEME_V->dump;	3172	pointer dump = SCHEME_V->dump;
3171		3173
3172	SCHEME_V->value = a;	3174	SCHEME_V->value = a;
3173		3175
3174	if (dump == NIL)	3176	if (dump == NIL)
3175	return NIL;	3177	return -1;
3176		3178
3177	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);	3179	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);
3178	SCHEME_V->args = car (dump) ; dump = cdr (dump);	3180	SCHEME_V->args = car (dump) ; dump = cdr (dump);
3179	SCHEME_V->envir = car (dump) ; dump = cdr (dump);	3181	SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3180	SCHEME_V->code = car (dump) ; dump = cdr (dump);	3182	SCHEME_V->code = car (dump) ; dump = cdr (dump);
3181		3183
3182	SCHEME_V->dump = dump;	3184	SCHEME_V->dump = dump;
3183		3185
3184	return S_T;	3186	return 0;
3185	}	3187	}
3186		3188
3187	static void	3189	static void
3188	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)	3190	s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3189	{	3191	{
…		…
3214		3216
3215	#endif	3217	#endif
3216		3218
3217	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3219	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3218		3220
3219	static pointer	3221	static int
3220	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3222	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3221	{	3223	{
3222	pointer args = SCHEME_V->args;	3224	pointer args = SCHEME_V->args;
3223	pointer x, y;	3225	pointer x, y;
3224		3226
…		…
3413	/* fall through */	3415	/* fall through */
3414		3416
3415	case OP_REAL_APPLY:	3417	case OP_REAL_APPLY:
3416	#endif	3418	#endif
3417	if (is_proc (SCHEME_V->code))	3419	if (is_proc (SCHEME_V->code))
3418	{
3419	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */	3420	s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3420	}
3421	else if (is_foreign (SCHEME_V->code))	3421	else if (is_foreign (SCHEME_V->code))
3422	{	3422	{
3423	/* Keep nested calls from GC'ing the arglist */	3423	/* Keep nested calls from GC'ing the arglist */
3424	push_recent_alloc (SCHEME_A_ args, NIL);	3424	push_recent_alloc (SCHEME_A_ args, NIL);
3425	x = SCHEME_V->code->object.ff (SCHEME_A_ args);	3425	x = SCHEME_V->code->object.ff (SCHEME_A_ args);
…		…
3592		3592
3593	case OP_IF1: /* if */	3593	case OP_IF1: /* if */
3594	if (is_true (SCHEME_V->value))	3594	if (is_true (SCHEME_V->value))
3595	SCHEME_V->code = car (SCHEME_V->code);	3595	SCHEME_V->code = car (SCHEME_V->code);
3596	else	3596	else
3597	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because	3597	SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3598
3599	* car(NIL) = NIL */
3600	s_goto (OP_EVAL);	3598	s_goto (OP_EVAL);
3601		3599
3602	case OP_LET0: /* let */	3600	case OP_LET0: /* let */
3603	SCHEME_V->args = NIL;	3601	SCHEME_V->args = NIL;
3604	SCHEME_V->value = SCHEME_V->code;	3602	SCHEME_V->value = SCHEME_V->code;
…		…
3914	SCHEME_V->code = car (args);	3912	SCHEME_V->code = car (args);
3915	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);	3913	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3916	s_goto (OP_APPLY);	3914	s_goto (OP_APPLY);
3917	}	3915	}
3918		3916
3919	abort ();	3917	if (USE_ERROR_CHECKING) abort ();
3920	}	3918	}
3921		3919
3922	static pointer	3920	static int
3923	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	3921	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3924	{	3922	{
3925	pointer args = SCHEME_V->args;	3923	pointer args = SCHEME_V->args;
3926	pointer x = car (args);	3924	pointer x = car (args);
3927	num v;	3925	num v;
3928		3926
…		…
4017		4015
4018	case OP_ADD: /* + */	4016	case OP_ADD: /* + */
4019	v = num_zero;	4017	v = num_zero;
4020		4018
4021	for (x = args; x != NIL; x = cdr (x))	4019	for (x = args; x != NIL; x = cdr (x))
4022	v = num_op ('+', v, nvalue (car (x)));	4020	v = num_op (NUM_ADD, v, nvalue (car (x)));
4023		4021
4024	s_return (mk_number (SCHEME_A_ v));	4022	s_return (mk_number (SCHEME_A_ v));
4025		4023
4026	case OP_MUL: /* * */	4024	case OP_MUL: /* * */
4027	v = num_one;	4025	v = num_one;
4028		4026
4029	for (x = args; x != NIL; x = cdr (x))	4027	for (x = args; x != NIL; x = cdr (x))
4030	v = num_op ('+', v, nvalue (car (x)));	4028	v = num_op (NUM_MUL, v, nvalue (car (x)));
4031		4029
4032	s_return (mk_number (SCHEME_A_ v));	4030	s_return (mk_number (SCHEME_A_ v));
4033		4031
4034	case OP_SUB: /* - */	4032	case OP_SUB: /* - */
4035	if (cdr (args) == NIL)	4033	if (cdr (args) == NIL)
…		…
4042	x = cdr (args);	4040	x = cdr (args);
4043	v = nvalue (car (args));	4041	v = nvalue (car (args));
4044	}	4042	}
4045		4043
4046	for (; x != NIL; x = cdr (x))	4044	for (; x != NIL; x = cdr (x))
4047	v = num_op ('+', v, nvalue (car (x)));	4045	v = num_op (NUM_SUB, v, nvalue (car (x)));
4048		4046
4049	s_return (mk_number (SCHEME_A_ v));	4047	s_return (mk_number (SCHEME_A_ v));
4050		4048
4051	case OP_DIV: /* / */	4049	case OP_DIV: /* / */
4052	if (cdr (args) == NIL)	4050	if (cdr (args) == NIL)
…		…
4059	x = cdr (args);	4057	x = cdr (args);
4060	v = nvalue (car (args));	4058	v = nvalue (car (args));
4061	}	4059	}
4062		4060
4063	for (; x != NIL; x = cdr (x))	4061	for (; x != NIL; x = cdr (x))
4064	{
4065	if (!is_zero_rvalue (rvalue (car (x))))	4062	if (!is_zero_rvalue (rvalue (car (x))))
4066	v = num_div (v, nvalue (car (x)));	4063	v = num_div (v, nvalue (car (x)));
4067	else	4064	else
4068	Error_0 ("/: division by zero");	4065	Error_0 ("/: division by zero");
4069	}
4070		4066
4071	s_return (mk_number (SCHEME_A_ v));	4067	s_return (mk_number (SCHEME_A_ v));
4072		4068
4073	case OP_INTDIV: /* quotient */	4069	case OP_INTDIV: /* quotient */
4074	if (cdr (args) == NIL)	4070	if (cdr (args) == NIL)
…		…
4083	}	4079	}
4084		4080
4085	for (; x != NIL; x = cdr (x))	4081	for (; x != NIL; x = cdr (x))
4086	{	4082	{
4087	if (ivalue (car (x)) != 0)	4083	if (ivalue (car (x)) != 0)
4088	v = num_op ('/', v, nvalue (car (x)));	4084	v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4089	else	4085	else
4090	Error_0 ("quotient: division by zero");	4086	Error_0 ("quotient: division by zero");
4091	}	4087	}
4092		4088
4093	s_return (mk_number (SCHEME_A_ v));	4089	s_return (mk_number (SCHEME_A_ v));
…		…
4248	len = ivalue (x);	4244	len = ivalue (x);
4249		4245
4250	if (cdr (args) != NIL)	4246	if (cdr (args) != NIL)
4251	fill = charvalue (cadr (args));	4247	fill = charvalue (cadr (args));
4252		4248
4253	s_return (mk_empty_string (SCHEME_A_ len, (char) fill));	4249	s_return (mk_empty_string (SCHEME_A_ len, fill));
4254	}	4250	}
4255		4251
4256	case OP_STRLEN: /* string-length */	4252	case OP_STRLEN: /* string-length */
4257	s_return (mk_integer (SCHEME_A_ strlength (x)));	4253	s_return (mk_integer (SCHEME_A_ strlength (x)));
4258		4254
…		…
4266	index = ivalue (cadr (args));	4262	index = ivalue (cadr (args));
4267		4263
4268	if (index >= strlength (x))	4264	if (index >= strlength (x))
4269	Error_1 ("string-ref: out of bounds:", cadr (args));	4265	Error_1 ("string-ref: out of bounds:", cadr (args));
4270		4266
4271	s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index]));	4267	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4272	}	4268	}
4273		4269
4274	case OP_STRSET: /* string-set! */	4270	case OP_STRSET: /* string-set! */
4275	{	4271	{
4276	char *str;	4272	char *str;
…		…
4287	if (index >= strlength (x))	4283	if (index >= strlength (x))
4288	Error_1 ("string-set!: out of bounds:", cadr (args));	4284	Error_1 ("string-set!: out of bounds:", cadr (args));
4289		4285
4290	c = charvalue (caddr (args));	4286	c = charvalue (caddr (args));
4291		4287
4292	str[index] = (char)c;	4288	str[index] = c;
4293	s_return (car (args));	4289	s_return (car (args));
4294	}	4290	}
4295		4291
4296	case OP_STRAPPEND: /* string-append */	4292	case OP_STRAPPEND: /* string-append */
4297	{	4293	{
…		…
4421	set_vector_elem (x, index, caddr (args));	4417	set_vector_elem (x, index, caddr (args));
4422	s_return (x);	4418	s_return (x);
4423	}	4419	}
4424	}	4420	}
4425		4421
4426	return S_T;	4422	if (USE_ERROR_CHECKING) abort ();
4427	}	4423	}
4428		4424
4429	INTERFACE int	4425	INTERFACE int
4430	is_list (SCHEME_P_ pointer a)	4426	is_list (SCHEME_P_ pointer a)
4431	{	4427	{
…		…
4478	return -1;	4474	return -1;
4479	}	4475	}
4480	}	4476	}
4481	}	4477	}
4482		4478
4483	static pointer	4479	static int
4484	opexe_r (SCHEME_P_ enum scheme_opcodes op)	4480	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4485	{	4481	{
4486	pointer x = SCHEME_V->args;	4482	pointer x = SCHEME_V->args;
4487		4483
4488	for (;;)	4484	for (;;)
4489	{	4485	{
…		…
4509	}	4505	}
4510		4506
4511	s_return (S_T);	4507	s_return (S_T);
4512	}	4508	}
4513		4509
4514	static pointer	4510	static int
4515	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4511	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4516	{	4512	{
4517	pointer args = SCHEME_V->args;	4513	pointer args = SCHEME_V->args;
4518	pointer a = car (args);	4514	pointer a = car (args);
4519	pointer d = cdr (args);	4515	pointer d = cdr (args);
…		…
4565	}	4561	}
4566		4562
4567	s_retbool (r);	4563	s_retbool (r);
4568	}	4564	}
4569		4565
4570	static pointer	4566	static int
4571	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4567	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4572	{	4568	{
4573	pointer args = SCHEME_V->args;	4569	pointer args = SCHEME_V->args;
4574	pointer a = car (args);	4570	pointer a = car (args);
4575	pointer x, y;	4571	pointer x, y;
…		…
4661	putstr (SCHEME_A_ "\n");	4657	putstr (SCHEME_A_ "\n");
4662		4658
4663	if (SCHEME_V->interactive_repl)	4659	if (SCHEME_V->interactive_repl)
4664	s_goto (OP_T0LVL);	4660	s_goto (OP_T0LVL);
4665	else	4661	else
4666	return NIL;	4662	return -1;
4667	}	4663	}
4668		4664
4669	case OP_REVERSE: /* reverse */	4665	case OP_REVERSE: /* reverse */
4670	s_return (reverse (SCHEME_A_ a));	4666	s_return (reverse (SCHEME_A_ a));
4671		4667
…		…
4728		4724
4729	case OP_QUIT: /* quit */	4725	case OP_QUIT: /* quit */
4730	if (is_pair (args))	4726	if (is_pair (args))
4731	SCHEME_V->retcode = ivalue (a);	4727	SCHEME_V->retcode = ivalue (a);
4732		4728
4733	return NIL;	4729	return -1;
4734		4730
4735	case OP_GC: /* gc */	4731	case OP_GC: /* gc */
4736	gc (SCHEME_A_ NIL, NIL);	4732	gc (SCHEME_A_ NIL, NIL);
4737	s_return (S_T);	4733	s_return (S_T);
4738		4734
…		…
4785	break;	4781	break;
4786	}	4782	}
4787		4783
4788	p = port_from_filename (SCHEME_A_ strvalue (a), prop);	4784	p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4789		4785
4790	if (p == NIL)	4786	s_return (p == NIL ? S_F : p);
4791	s_return (S_F);
4792
4793	s_return (p);
4794	}	4787	}
4795		4788
4796	# if USE_STRING_PORTS	4789	# if USE_STRING_PORTS
4797		4790
4798	case OP_OPEN_INSTRING: /* open-input-string */	4791	case OP_OPEN_INSTRING: /* open-input-string */
…		…
4813	}	4806	}
4814		4807
4815	p = port_from_string (SCHEME_A_ strvalue (a),	4808	p = port_from_string (SCHEME_A_ strvalue (a),
4816	strvalue (a) + strlength (a), prop);	4809	strvalue (a) + strlength (a), prop);
4817		4810
4818	if (p == NIL)	4811	s_return (p == NIL ? S_F : p);
4819	s_return (S_F);
4820
4821	s_return (p);
4822	}	4812	}
4823		4813
4824	case OP_OPEN_OUTSTRING: /* open-output-string */	4814	case OP_OPEN_OUTSTRING: /* open-output-string */
4825	{	4815	{
4826	pointer p;	4816	pointer p;
4827		4817
4828	if (a == NIL)	4818	if (a == NIL)
4829	{
4830	p = port_from_scratch (SCHEME_A);	4819	p = port_from_scratch (SCHEME_A);
4831
4832	if (p == NIL)
4833	s_return (S_F);
4834	}
4835	else	4820	else
4836	{
4837	p = port_from_string (SCHEME_A_ strvalue (a),	4821	p = port_from_string (SCHEME_A_ strvalue (a),
4838	strvalue (a) + strlength (a), port_output);	4822	strvalue (a) + strlength (a), port_output);
4839		4823
4840	if (p == NIL)	4824	s_return (p == NIL ? S_F : p);
4841	s_return (S_F);
4842	}
4843
4844	s_return (p);
4845	}	4825	}
4846		4826
4847	case OP_GET_OUTSTRING: /* get-output-string */	4827	case OP_GET_OUTSTRING: /* get-output-string */
4848	{	4828	{
4849	port *p;	4829	port *p;
…		…
4888	case OP_CURR_ENV: /* current-environment */	4868	case OP_CURR_ENV: /* current-environment */
4889	s_return (SCHEME_V->envir);	4869	s_return (SCHEME_V->envir);
4890		4870
4891	}	4871	}
4892		4872
4893	abort ();	4873	if (USE_ERROR_CHECKING) abort ();
4894	}	4874	}
4895		4875
4896	static pointer	4876	static int
4897	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4877	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4898	{	4878	{
		4879	pointer args = SCHEME_V->args;
4899	pointer x;	4880	pointer x;
4900		4881
4901	if (SCHEME_V->nesting != 0)	4882	if (SCHEME_V->nesting != 0)
4902	{	4883	{
4903	int n = SCHEME_V->nesting;	4884	int n = SCHEME_V->nesting;
…		…
4910	switch (op)	4891	switch (op)
4911	{	4892	{
4912	/* ========== reading part ========== */	4893	/* ========== reading part ========== */
4913	#if USE_PORTS	4894	#if USE_PORTS
4914	case OP_READ:	4895	case OP_READ:
4915	if (!is_pair (SCHEME_V->args))	4896	if (!is_pair (args))
4916	s_goto (OP_READ_INTERNAL);	4897	s_goto (OP_READ_INTERNAL);
4917		4898
4918	if (!is_inport (car (SCHEME_V->args)))	4899	if (!is_inport (car (args)))
4919	Error_1 ("read: not an input port:", car (SCHEME_V->args));	4900	Error_1 ("read: not an input port:", car (args));
4920		4901
4921	if (car (SCHEME_V->args) == SCHEME_V->inport)	4902	if (car (args) == SCHEME_V->inport)
4922	s_goto (OP_READ_INTERNAL);	4903	s_goto (OP_READ_INTERNAL);
4923		4904
4924	x = SCHEME_V->inport;	4905	x = SCHEME_V->inport;
4925	SCHEME_V->inport = car (SCHEME_V->args);	4906	SCHEME_V->inport = car (args);
4926	x = cons (x, NIL);	4907	x = cons (x, NIL);
4927	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);	4908	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
4928	s_goto (OP_READ_INTERNAL);	4909	s_goto (OP_READ_INTERNAL);
4929		4910
4930	case OP_READ_CHAR: /* read-char */	4911	case OP_READ_CHAR: /* read-char */
4931	case OP_PEEK_CHAR: /* peek-char */	4912	case OP_PEEK_CHAR: /* peek-char */
4932	{	4913	{
4933	int c;	4914	int c;
4934		4915
4935	if (is_pair (SCHEME_V->args))	4916	if (is_pair (args))
4936	{	4917	{
4937	if (car (SCHEME_V->args) != SCHEME_V->inport)	4918	if (car (args) != SCHEME_V->inport)
4938	{	4919	{
4939	x = SCHEME_V->inport;	4920	x = SCHEME_V->inport;
4940	x = cons (x, NIL);	4921	x = cons (x, NIL);
4941	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);	4922	s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
4942	SCHEME_V->inport = car (SCHEME_V->args);	4923	SCHEME_V->inport = car (args);
4943	}	4924	}
4944	}	4925	}
4945		4926
4946	c = inchar (SCHEME_A);	4927	c = inchar (SCHEME_A);
4947		4928
…		…
4957	case OP_CHAR_READY: /* char-ready? */	4938	case OP_CHAR_READY: /* char-ready? */
4958	{	4939	{
4959	pointer p = SCHEME_V->inport;	4940	pointer p = SCHEME_V->inport;
4960	int res;	4941	int res;
4961		4942
4962	if (is_pair (SCHEME_V->args))	4943	if (is_pair (args))
4963	p = car (SCHEME_V->args);	4944	p = car (args);
4964		4945
4965	res = p->object.port->kind & port_string;	4946	res = p->object.port->kind & port_string;
4966		4947
4967	s_retbool (res);	4948	s_retbool (res);
4968	}	4949	}
4969		4950
4970	case OP_SET_INPORT: /* set-input-port */	4951	case OP_SET_INPORT: /* set-input-port */
4971	SCHEME_V->inport = car (SCHEME_V->args);	4952	SCHEME_V->inport = car (args);
4972	s_return (SCHEME_V->value);	4953	s_return (SCHEME_V->value);
4973		4954
4974	case OP_SET_OUTPORT: /* set-output-port */	4955	case OP_SET_OUTPORT: /* set-output-port */
4975	SCHEME_V->outport = car (SCHEME_V->args);	4956	SCHEME_V->outport = car (args);
4976	s_return (SCHEME_V->value);	4957	s_return (SCHEME_V->value);
4977	#endif	4958	#endif
4978		4959
4979	case OP_RDSEXPR:	4960	case OP_RDSEXPR:
4980	switch (SCHEME_V->tok)	4961	switch (SCHEME_V->tok)
…		…
5066	}	5047	}
5067		5048
5068	break;	5049	break;
5069		5050
5070	case OP_RDLIST:	5051	case OP_RDLIST:
5071	SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args);	5052	SCHEME_V->args = cons (SCHEME_V->value, args);
5072	SCHEME_V->tok = token (SCHEME_A);	5053	SCHEME_V->tok = token (SCHEME_A);
5073		5054
5074	switch (SCHEME_V->tok)	5055	switch (SCHEME_V->tok)
5075	{	5056	{
5076	case TOK_EOF:	5057	case TOK_EOF:
…		…
5104	case OP_RDDOT:	5085	case OP_RDDOT:
5105	if (token (SCHEME_A) != TOK_RPAREN)	5086	if (token (SCHEME_A) != TOK_RPAREN)
5106	Error_0 ("syntax error: illegal dot expression");	5087	Error_0 ("syntax error: illegal dot expression");
5107		5088
5108	SCHEME_V->nesting_stack[SCHEME_V->file_i]--;	5089	SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5109	s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args));	5090	s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args));
5110		5091
5111	case OP_RDQUOTE:	5092	case OP_RDQUOTE:
5112	s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));	5093	s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));
5113		5094
5114	case OP_RDQQUOTE:	5095	case OP_RDQQUOTE:
…		…
5136	SCHEME_V->args = SCHEME_V->value;	5117	SCHEME_V->args = SCHEME_V->value;
5137	s_goto (OP_VECTOR);	5118	s_goto (OP_VECTOR);
5138		5119
5139	/* ========== printing part ========== */	5120	/* ========== printing part ========== */
5140	case OP_P0LIST:	5121	case OP_P0LIST:
5141	if (is_vector (SCHEME_V->args))	5122	if (is_vector (args))
5142	{	5123	{
5143	putstr (SCHEME_A_ "#(");	5124	putstr (SCHEME_A_ "#(");
5144	SCHEME_V->args = cons (SCHEME_V->args, mk_integer (SCHEME_A_ 0));	5125	SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0));
5145	s_goto (OP_PVECFROM);	5126	s_goto (OP_PVECFROM);
5146	}	5127	}
5147	else if (is_environment (SCHEME_V->args))	5128	else if (is_environment (args))
5148	{	5129	{
5149	putstr (SCHEME_A_ "#<ENVIRONMENT>");	5130	putstr (SCHEME_A_ "#<ENVIRONMENT>");
5150	s_return (S_T);	5131	s_return (S_T);
5151	}	5132	}
5152	else if (!is_pair (SCHEME_V->args))	5133	else if (!is_pair (args))
5153	{	5134	{
5154	printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag);	5135	printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5155	s_return (S_T);	5136	s_return (S_T);
5156	}	5137	}
5157	else if (car (SCHEME_V->args) == SCHEME_V->QUOTE && ok_abbrev (cdr (SCHEME_V->args)))	5138	else
5158	{	5139	{
		5140	pointer a = car (args);
		5141	pointer b = cdr (args);
		5142	int ok_abbr = ok_abbrev (b);
		5143	SCHEME_V->args = car (b);
		5144
		5145	if (a == SCHEME_V->QUOTE && ok_abbr)
5159	putstr (SCHEME_A_ "'");	5146	putstr (SCHEME_A_ "'");
5160	SCHEME_V->args = cadr (SCHEME_V->args);	5147	else if (a == SCHEME_V->QQUOTE && ok_abbr)
		5148	putstr (SCHEME_A_ "`");
		5149	else if (a == SCHEME_V->UNQUOTE && ok_abbr)
		5150	putstr (SCHEME_A_ ",");
		5151	else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
		5152	putstr (SCHEME_A_ ",@");
		5153	else
		5154	{
		5155	putstr (SCHEME_A_ "(");
		5156	s_save (SCHEME_A_ OP_P1LIST, b, NIL);
		5157	SCHEME_V->args = a;
		5158	}
		5159
5161	s_goto (OP_P0LIST);	5160	s_goto (OP_P0LIST);
5162	}	5161	}
5163	else if (car (SCHEME_V->args) == SCHEME_V->QQUOTE && ok_abbrev (cdr (SCHEME_V->args)))	5162
		5163	case OP_P1LIST:
		5164	if (is_pair (args))
5164	{	5165	{
		5166	s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5165	putstr (SCHEME_A_ "`");	5167	putstr (SCHEME_A_ " ");
5166	SCHEME_V->args = cadr (SCHEME_V->args);	5168	SCHEME_V->args = car (args);
5167	s_goto (OP_P0LIST);	5169	s_goto (OP_P0LIST);
5168	}	5170	}
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))	5171	else if (is_vector (args))
5198	{	5172	{
5199	s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);	5173	s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);
5200	putstr (SCHEME_A_ " . ");	5174	putstr (SCHEME_A_ " . ");
5201	s_goto (OP_P0LIST);	5175	s_goto (OP_P0LIST);
5202	}	5176	}
5203	else	5177	else
5204	{	5178	{
5205	if (SCHEME_V->args != NIL)	5179	if (args != NIL)
5206	{	5180	{
5207	putstr (SCHEME_A_ " . ");	5181	putstr (SCHEME_A_ " . ");
5208	printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag);	5182	printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5209	}	5183	}
5210		5184
5211	putstr (SCHEME_A_ ")");	5185	putstr (SCHEME_A_ ")");
5212	s_return (S_T);	5186	s_return (S_T);
5213	}	5187	}
5214		5188
5215	case OP_PVECFROM:	5189	case OP_PVECFROM:
5216	{	5190	{
5217	int i = ivalue_unchecked (cdr (SCHEME_V->args));	5191	int i = ivalue_unchecked (cdr (args));
5218	pointer vec = car (SCHEME_V->args);	5192	pointer vec = car (args);
5219	int len = veclength (vec);	5193	int len = veclength (vec);
5220		5194
5221	if (i == len)	5195	if (i == len)
5222	{	5196	{
5223	putstr (SCHEME_A_ ")");	5197	putstr (SCHEME_A_ ")");
…		…
5225	}	5199	}
5226	else	5200	else
5227	{	5201	{
5228	pointer elem = vector_elem (vec, i);	5202	pointer elem = vector_elem (vec, i);
5229		5203
5230	ivalue_unchecked (cdr (SCHEME_V->args)) = i + 1;	5204	ivalue_unchecked (cdr (args)) = i + 1;
5231	s_save (SCHEME_A_ OP_PVECFROM, SCHEME_V->args, NIL);	5205	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5232	SCHEME_V->args = elem;	5206	SCHEME_V->args = elem;
5233		5207
5234	if (i > 0)	5208	if (i > 0)
5235	putstr (SCHEME_A_ " ");	5209	putstr (SCHEME_A_ " ");
5236		5210
5237	s_goto (OP_P0LIST);	5211	s_goto (OP_P0LIST);
5238	}	5212	}
5239	}	5213	}
5240	}	5214	}
5241		5215
5242	abort ();	5216	if (USE_ERROR_CHECKING) abort ();
5243	}	5217	}
5244		5218
5245	static pointer	5219	static int
5246	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5220	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5247	{	5221	{
		5222	pointer args = SCHEME_V->args;
		5223	pointer a = car (args);
5248	pointer x, y;	5224	pointer x, y;
5249		5225
5250	switch (op)	5226	switch (op)
5251	{	5227	{
5252	case OP_LIST_LENGTH: /* length *//* a.k */	5228	case OP_LIST_LENGTH: /* length *//* a.k */
5253	{	5229	{
5254	long v = list_length (SCHEME_A_ car (SCHEME_V->args));	5230	long v = list_length (SCHEME_A_ a);
5255		5231
5256	if (v < 0)	5232	if (v < 0)
5257	Error_1 ("length: not a list:", car (SCHEME_V->args));	5233	Error_1 ("length: not a list:", a);
5258		5234
5259	s_return (mk_integer (SCHEME_A_ v));	5235	s_return (mk_integer (SCHEME_A_ v));
5260	}	5236	}
5261		5237
5262	case OP_ASSQ: /* assq *//* a.k */	5238	case OP_ASSQ: /* assq *//* a.k */
5263	x = car (SCHEME_V->args);	5239	x = a;
5264		5240
5265	for (y = cadr (SCHEME_V->args); is_pair (y); y = cdr (y))	5241	for (y = cadr (args); is_pair (y); y = cdr (y))
5266	{	5242	{
5267	if (!is_pair (car (y)))	5243	if (!is_pair (car (y)))
5268	Error_0 ("unable to handle non pair element");	5244	Error_0 ("unable to handle non pair element");
5269		5245
5270	if (x == caar (y))	5246	if (x == caar (y))
…		…
5276	else	5252	else
5277	s_return (S_F);	5253	s_return (S_F);
5278		5254
5279		5255
5280	case OP_GET_CLOSURE: /* get-closure-code *//* a.k */	5256	case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5281	SCHEME_V->args = car (SCHEME_V->args);	5257	SCHEME_V->args = a;
5282		5258
5283	if (SCHEME_V->args == NIL)	5259	if (SCHEME_V->args == NIL)
5284	s_return (S_F);	5260	s_return (S_F);
5285	else if (is_closure (SCHEME_V->args))	5261	else if (is_closure (SCHEME_V->args))
5286	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));	5262	s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
…		…
5292	case OP_CLOSUREP: /* closure? */	5268	case OP_CLOSUREP: /* closure? */
5293	/*	5269	/*
5294	* Note, macro object is also a closure.	5270	* Note, macro object is also a closure.
5295	* Therefore, (closure? <#MACRO>) ==> #t	5271	* Therefore, (closure? <#MACRO>) ==> #t
5296	*/	5272	*/
5297	s_retbool (is_closure (car (SCHEME_V->args)));	5273	s_retbool (is_closure (a));
5298		5274
5299	case OP_MACROP: /* macro? */	5275	case OP_MACROP: /* macro? */
5300	s_retbool (is_macro (car (SCHEME_V->args)));	5276	s_retbool (is_macro (a));
5301	}	5277	}
5302		5278
5303	abort ();	5279	if (USE_ERROR_CHECKING) abort ();
5304	}	5280	}
5305		5281
		5282	/* 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);	5283	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5307		5284
5308	typedef int (*test_predicate) (pointer);	5285	typedef int (*test_predicate)(pointer);
5309	static int	5286	static int
5310	is_any (pointer p)	5287	is_any (pointer p)
5311	{	5288	{
5312	return 1;	5289	return 1;
5313	}	5290	}
5314		5291
5315	static int	5292	static int
5316	is_nonneg (pointer p)	5293	is_nonneg (pointer p)
5317	{	5294	{
5318	return ivalue (p) >= 0 && is_integer (p);	5295	return ivalue (p) >= 0 && is_integer (p);
		5296	}
		5297
		5298	static int
		5299	tst_is_list (pointer p)
		5300	{
		5301	return p == NIL || is_pair (p);
5319	}	5302	}
5320		5303
5321	/* Correspond carefully with following defines! */	5304	/* Correspond carefully with following defines! */
5322	static struct	5305	static struct
5323	{	5306	{
5324	test_predicate fct;	5307	test_predicate fct;
5325	const char *kind;	5308	const char *kind;
5326	} tests[] =	5309	} tests[] =
5327	{	5310	{
5328	{ 0, 0}, /* unused */	5311	{ is_any, 0 },
5329	{ is_any, 0},	5312	{ is_string, "string" },
5330	{ is_string, "string" },	5313	{ is_symbol, "symbol" },
5331	{ is_symbol, "symbol" },	5314	{ is_port, "port" },
5332	{ is_port, "port" },
5333	{ is_inport, "input port" },	5315	{ is_inport, "input port" },
5334	{ is_outport, "output port" },	5316	{ is_outport, "output port" },
5335	{ is_environment, "environment" },	5317	{ is_environment, "environment" },
5336	{ is_pair, "pair" },	5318	{ is_pair, "pair" },
5337	{ 0, "pair or '()" },	5319	{ tst_is_list, "pair or '()" },
5338	{ is_character, "character" },	5320	{ is_character, "character" },
5339	{ is_vector, "vector" },	5321	{ is_vector, "vector" },
5340	{ is_number, "number" },	5322	{ is_number, "number" },
5341	{ is_integer, "integer" },	5323	{ is_integer, "integer" },
5342	{ is_nonneg, "non-negative integer" }	5324	{ is_nonneg, "non-negative integer" }
5343	};	5325	};
5344		5326
5345	#define TST_NONE 0	5327	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5346	#define TST_ANY "\001"	5328	#define TST_ANY "\001"
5347	#define TST_STRING "\002"	5329	#define TST_STRING "\002"
5348	#define TST_SYMBOL "\003"	5330	#define TST_SYMBOL "\003"
5349	#define TST_PORT "\004"	5331	#define TST_PORT "\004"
5350	#define TST_INPORT "\005"	5332	#define TST_INPORT "\005"
5351	#define TST_OUTPORT "\006"	5333	#define TST_OUTPORT "\006"
5352	#define TST_ENVIRONMENT "\007"	5334	#define TST_ENVIRONMENT "\007"
5353	#define TST_PAIR "\010"	5335	#define TST_PAIR "\010"
5354	#define TST_LIST "\011"	5336	#define TST_LIST "\011"
5355	#define TST_CHAR "\012"	5337	#define TST_CHAR "\012"
5356	#define TST_VECTOR "\013"	5338	#define TST_VECTOR "\013"
5357	#define TST_NUMBER "\014"	5339	#define TST_NUMBER "\014"
5358	#define TST_INTEGER "\015"	5340	#define TST_INTEGER "\015"
5359	#define TST_NATURAL "\016"	5341	#define TST_NATURAL "\016"
		5342
		5343	#define INF_ARG 0xff
		5344	#define UNNAMED_OP ""
		5345
		5346	static const char opnames[] =
		5347	#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
		5348	#include "opdefines.h"
		5349	#undef OP_DEF
		5350	;
		5351
		5352	static const char *
		5353	opname (int idx)
		5354	{
		5355	const char *name = opnames;
		5356
		5357	/* should do this at compile time, but would require external program, right? */
		5358	while (idx--)
		5359	name += strlen (name) + 1;
		5360
		5361	return *name ? name : "ILLEGAL";
		5362	}
		5363
		5364	static const char *
		5365	procname (pointer x)
		5366	{
		5367	return opname (procnum (x));
		5368	}
5360		5369
5361	typedef struct	5370	typedef struct
5362	{	5371	{
5363	dispatch_func func;	5372	uint8_t func;
5364	char *name;	5373	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
		5374	uint8_t builtin;
5365	int min_arity;	5375	uint8_t min_arity;
5366	int max_arity;	5376	uint8_t max_arity;
5367	char *arg_tests_encoding;	5377	char arg_tests_encoding[3];
5368	} op_code_info;	5378	} op_code_info;
5369		5379
5370	#define INF_ARG 0xffff
5371
5372	static op_code_info dispatch_table[] = {	5380	static const op_code_info dispatch_table[] = {
5373	#define OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},	5381	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
5374	#include "opdefines.h"	5382	#include "opdefines.h"
		5383	#undef OP_DEF
5375	{0}	5384	{0}
5376	};	5385	};
5377		5386
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 */	5387	/* kernel of this interpreter */
5391	static void	5388	static void ecb_hot
5392	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5389	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5393	{	5390	{
5394	SCHEME_V->op = op;	5391	SCHEME_V->op = op;
5395		5392
5396	for (;;)	5393	for (;;)
5397	{	5394	{
5398	op_code_info *pcd = dispatch_table + SCHEME_V->op;	5395	const op_code_info *pcd = dispatch_table + SCHEME_V->op;
5399		5396
5400	#if USE_ERROR_CHECKING	5397	#if USE_ERROR_CHECKING
5401	if (pcd->name) /* if built-in function, check arguments */	5398	if (pcd->builtin) /* if built-in function, check arguments */
5402	{	5399	{
5403	int ok = 1;
5404	char msg[STRBUFFSIZE];	5400	char msg[STRBUFFSIZE];
5405	int n = list_length (SCHEME_A_ SCHEME_V->args);	5401	int n = list_length (SCHEME_A_ SCHEME_V->args);
5406		5402
5407	/* Check number of arguments */	5403	/* Check number of arguments */
5408	if (ecb_expect_false (n < pcd->min_arity))	5404	if (ecb_expect_false (n < pcd->min_arity))
5409	{	5405	{
5410	ok = 0;
5411	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5406	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5412	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);	5407	opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
		5408	xError_1 (SCHEME_A_ msg, 0);
		5409	continue;
5413	}	5410	}
5414	else if (ecb_expect_false (n > pcd->max_arity))	5411	else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
5415	{	5412	{
5416	ok = 0;
5417	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5413	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5418	pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);	5414	opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
		5415	xError_1 (SCHEME_A_ msg, 0);
		5416	continue;
5419	}	5417	}
5420		5418	else
5421	if (ecb_expect_false (ok))
5422	{	5419	{
5423	if (pcd->arg_tests_encoding)	5420	if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */
5424	{	5421	{
5425	int i = 0;	5422	int i = 0;
5426	int j;	5423	int j;
5427	const char *t = pcd->arg_tests_encoding;	5424	const char *t = pcd->arg_tests_encoding;
5428	pointer arglist = SCHEME_V->args;	5425	pointer arglist = SCHEME_V->args;
5429		5426
5430	do	5427	do
5431	{	5428	{
5432	pointer arg = car (arglist);	5429	pointer arg = car (arglist);
5433		5430
5434	j = (int) t[0];	5431	j = t[0];
5435		5432
5436	if (j == TST_LIST[0])	5433	if (!tests[j - 1].fct (arg))
5437	{
5438	if (arg != NIL && !is_pair (arg))
5439	break;	5434	break;
5440	}
5441	else
5442	{
5443	if (!tests[j].fct (arg))
5444	break;
5445	}
5446		5435
5447	if (t[1] != 0) /* last test is replicated as necessary */	5436	if (t[1]) /* last test is replicated as necessary */
5448	t++;	5437	t++;
5449		5438
5450	arglist = cdr (arglist);	5439	arglist = cdr (arglist);
5451	i++;	5440	i++;
5452	}	5441	}
5453	while (i < n);	5442	while (i < n);
5454		5443
5455	if (i < n)	5444	if (i < n)
5456	{	5445	{
5457	ok = 0;
5458	snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind);	5446	snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind);
		5447	xError_1 (SCHEME_A_ msg, 0);
		5448	continue;
5459	}	5449	}
5460	}	5450	}
5461	}	5451	}
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	}	5452	}
5471	#endif	5453	#endif
5472		5454
5473	ok_to_freely_gc (SCHEME_A);	5455	ok_to_freely_gc (SCHEME_A);
5474		5456
		5457	static const dispatch_func dispatch_funcs[] = {
		5458	opexe_0,
		5459	opexe_1,
		5460	opexe_2,
		5461	opexe_3,
		5462	opexe_4,
		5463	opexe_5,
		5464	opexe_6,
		5465	};
		5466
5475	if (ecb_expect_false (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL))	5467	if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5476	return;	5468	return;
5477		5469
5478	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	5470	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5479	{	5471	{
5480	xwrstr ("No memory!\n");	5472	xwrstr ("No memory!\n");
…		…
5579	return OP_C0STREAM; /* cons-stream */	5571	return OP_C0STREAM; /* cons-stream */
5580	}	5572	}
5581	}	5573	}
5582		5574
5583	#if USE_MULTIPLICITY	5575	#if USE_MULTIPLICITY
5584	scheme *	5576	ecb_cold scheme *
5585	scheme_init_new ()	5577	scheme_init_new ()
5586	{	5578	{
5587	scheme *sc = malloc (sizeof (scheme));	5579	scheme *sc = malloc (sizeof (scheme));
5588		5580
5589	if (!scheme_init (SCHEME_A))	5581	if (!scheme_init (SCHEME_A))
…		…
5594	else	5586	else
5595	return sc;	5587	return sc;
5596	}	5588	}
5597	#endif	5589	#endif
5598		5590
5599	int	5591	ecb_cold int
5600	scheme_init (SCHEME_P)	5592	scheme_init (SCHEME_P)
5601	{	5593	{
5602	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	5594	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5603	pointer x;	5595	pointer x;
5604		5596
…		…
5677		5669
5678	for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)	5670	for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
5679	assign_syntax (SCHEME_A_ syntax_names[i]);	5671	assign_syntax (SCHEME_A_ syntax_names[i]);
5680	}	5672	}
5681		5673
		5674	// TODO: should iterate via strlen, to avoid n² complexity
5682	for (i = 0; i < n; i++)	5675	for (i = 0; i < n; i++)
5683	if (dispatch_table[i].name != 0)	5676	if (dispatch_table[i].builtin)
5684	assign_proc (SCHEME_A_ i, dispatch_table[i].name);	5677	assign_proc (SCHEME_A_ i, opname (i));
5685		5678
5686	/* initialization of global pointers to special symbols */	5679	/* initialization of global pointers to special symbols */
5687	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");	5680	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5688	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");	5681	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5689	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");	5682	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
…		…
5728	scheme_set_external_data (SCHEME_P_ void *p)	5721	scheme_set_external_data (SCHEME_P_ void *p)
5729	{	5722	{
5730	SCHEME_V->ext_data = p;	5723	SCHEME_V->ext_data = p;
5731	}	5724	}
5732		5725
5733	void	5726	ecb_cold void
5734	scheme_deinit (SCHEME_P)	5727	scheme_deinit (SCHEME_P)
5735	{	5728	{
5736	int i;	5729	int i;
5737		5730
5738	#if SHOW_ERROR_LINE	5731	#if SHOW_ERROR_LINE
…		…
5830	{	5823	{
5831	dump_stack_reset (SCHEME_A);	5824	dump_stack_reset (SCHEME_A);
5832	SCHEME_V->envir = SCHEME_V->global_env;	5825	SCHEME_V->envir = SCHEME_V->global_env;
5833	SCHEME_V->file_i = 0;	5826	SCHEME_V->file_i = 0;
5834	SCHEME_V->load_stack[0].kind = port_input | port_string;	5827	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 */	5828	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);	5829	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;	5830	SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5838	#if USE_PORTS	5831	#if USE_PORTS
5839	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);	5832	SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5840	#endif	5833	#endif
5841	SCHEME_V->retcode = 0;	5834	SCHEME_V->retcode = 0;
5842	SCHEME_V->interactive_repl = 0;	5835	SCHEME_V->interactive_repl = 0;

Diff Legend

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