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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.19 by root, Thu Nov 26 21:36:11 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);
252		242
253	INTERFACE INLINE int	243	INTERFACE int
254	is_vector (pointer p)	244	is_vector (pointer p)
255	{	245	{
256	return type (p) == T_VECTOR;	246	return type (p) == T_VECTOR;
257	}	247	}
258		248
…		…
267	vector_length (pointer vec)	257	vector_length (pointer vec)
268	{	258	{
269	return vec->object.vector.length;	259	return vec->object.vector.length;
270	}	260	}
271		261
272	INTERFACE INLINE int	262	INTERFACE int
273	is_number (pointer p)	263	is_number (pointer p)
274	{	264	{
275	return type (p) == T_NUMBER;	265	return type (p) == T_NUMBER;
276	}	266	}
277		267
278	INTERFACE INLINE int	268	INTERFACE int
279	is_integer (pointer p)	269	is_integer (pointer p)
280	{	270	{
281	if (!is_number (p))	271	return is_number (p) && num_is_fixnum (p->object.number);
282	return 0;
283
284	if (num_is_integer (p) \|\| ivalue (p) == rvalue (p))
285	return 1;
286
287	return 0;
288	}	272	}
289		273
290	INTERFACE INLINE int	274	INTERFACE int
291	is_real (pointer p)	275	is_real (pointer p)
292	{	276	{
293	return is_number (p) && !num_is_fixnum (p->object.number);	277	return is_number (p) && !num_is_fixnum (p->object.number);
294	}	278	}
295		279
296	INTERFACE INLINE int	280	INTERFACE int
297	is_character (pointer p)	281	is_character (pointer p)
298	{	282	{
299	return type (p) == T_CHARACTER;	283	return type (p) == T_CHARACTER;
300	}	284	}
301		285
302	INTERFACE INLINE char *	286	INTERFACE char *
303	string_value (pointer p)	287	string_value (pointer p)
304	{	288	{
305	return strvalue (p);	289	return strvalue (p);
306	}	290	}
307		291
308	INLINE num	292	ecb_inline num
309	nvalue (pointer p)	293	nvalue (pointer p)
310	{	294	{
311	return (p)->object.number;	295	return (p)->object.number;
312	}	296	}
313		297
…		…
343	#else	327	#else
344	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)	328	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)
345	# define set_num_integer(p) 0	329	# define set_num_integer(p) 0
346	# define set_num_real(p) 0	330	# define set_num_real(p) 0
347	#endif	331	#endif
		332
348	INTERFACE long	333	INTERFACE long
349	charvalue (pointer p)	334	charvalue (pointer p)
350	{	335	{
351	return ivalue_unchecked (p);	336	return ivalue_unchecked (p);
352	}	337	}
353		338
354	INTERFACE INLINE int	339	INTERFACE int
355	is_port (pointer p)	340	is_port (pointer p)
356	{	341	{
357	return type (p) == T_PORT;	342	return type (p) == T_PORT;
358	}	343	}
359		344
360	INTERFACE INLINE int	345	INTERFACE int
361	is_inport (pointer p)	346	is_inport (pointer p)
362	{	347	{
363	return is_port (p) && p->object.port->kind & port_input;	348	return is_port (p) && p->object.port->kind & port_input;
364	}	349	}
365		350
366	INTERFACE INLINE int	351	INTERFACE int
367	is_outport (pointer p)	352	is_outport (pointer p)
368	{	353	{
369	return is_port (p) && p->object.port->kind & port_output;	354	return is_port (p) && p->object.port->kind & port_output;
370	}	355	}
371		356
372	INTERFACE INLINE int	357	INTERFACE int
373	is_pair (pointer p)	358	is_pair (pointer p)
374	{	359	{
375	return type (p) == T_PAIR;	360	return type (p) == T_PAIR;
376	}	361	}
377		362
…		…
409	pair_cdr (pointer p)	394	pair_cdr (pointer p)
410	{	395	{
411	return cdr (p);	396	return cdr (p);
412	}	397	}
413		398
414	INTERFACE INLINE int	399	INTERFACE int
415	is_symbol (pointer p)	400	is_symbol (pointer p)
416	{	401	{
417	return type (p) == T_SYMBOL;	402	return type (p) == T_SYMBOL;
418	}	403	}
419		404
420	INTERFACE INLINE char *	405	INTERFACE char *
421	symname (pointer p)	406	symname (pointer p)
422	{	407	{
423	return strvalue (car (p));	408	return strvalue (car (p));
424	}	409	}
425		410
426	#if USE_PLIST	411	#if USE_PLIST
427	SCHEME_EXPORT INLINE int	412	SCHEME_EXPORT int
428	hasprop (pointer p)	413	hasprop (pointer p)
429	{	414	{
430	return typeflag (p) & T_SYMBOL;	415	return typeflag (p) & T_SYMBOL;
431	}	416	}
432		417
433	# define symprop(p) cdr(p)	418	# define symprop(p) cdr(p)
434	#endif	419	#endif
435		420
436	INTERFACE INLINE int	421	INTERFACE int
437	is_syntax (pointer p)	422	is_syntax (pointer p)
438	{	423	{
439	return typeflag (p) & T_SYNTAX;	424	return typeflag (p) & T_SYNTAX;
440	}	425	}
441		426
442	INTERFACE INLINE int	427	INTERFACE int
443	is_proc (pointer p)	428	is_proc (pointer p)
444	{	429	{
445	return type (p) == T_PROC;	430	return type (p) == T_PROC;
446	}	431	}
447		432
448	INTERFACE INLINE int	433	INTERFACE int
449	is_foreign (pointer p)	434	is_foreign (pointer p)
450	{	435	{
451	return type (p) == T_FOREIGN;	436	return type (p) == T_FOREIGN;
452	}	437	}
453		438
454	INTERFACE INLINE char *	439	INTERFACE char *
455	syntaxname (pointer p)	440	syntaxname (pointer p)
456	{	441	{
457	return strvalue (car (p));	442	return strvalue (car (p));
458	}	443	}
459		444
460	#define procnum(p) ivalue (p)	445	#define procnum(p) ivalue (p)
461	static const char *procname (pointer x);	446	static const char *procname (pointer x);
462		447
463	INTERFACE INLINE int	448	INTERFACE int
464	is_closure (pointer p)	449	is_closure (pointer p)
465	{	450	{
466	return type (p) == T_CLOSURE;	451	return type (p) == T_CLOSURE;
467	}	452	}
468		453
469	INTERFACE INLINE int	454	INTERFACE int
470	is_macro (pointer p)	455	is_macro (pointer p)
471	{	456	{
472	return type (p) == T_MACRO;	457	return type (p) == T_MACRO;
473	}	458	}
474		459
475	INTERFACE INLINE pointer	460	INTERFACE pointer
476	closure_code (pointer p)	461	closure_code (pointer p)
477	{	462	{
478	return car (p);	463	return car (p);
479	}	464	}
480		465
481	INTERFACE INLINE pointer	466	INTERFACE pointer
482	closure_env (pointer p)	467	closure_env (pointer p)
483	{	468	{
484	return cdr (p);	469	return cdr (p);
485	}	470	}
486		471
487	INTERFACE INLINE int	472	INTERFACE int
488	is_continuation (pointer p)	473	is_continuation (pointer p)
489	{	474	{
490	return type (p) == T_CONTINUATION;	475	return type (p) == T_CONTINUATION;
491	}	476	}
492		477
493	#define cont_dump(p) cdr (p)	478	#define cont_dump(p) cdr (p)
494	#define set_cont_dump(p,v) set_cdr ((p), (v))	479	#define set_cont_dump(p,v) set_cdr ((p), (v))
495		480
496	/* To do: promise should be forced ONCE only */	481	/* To do: promise should be forced ONCE only */
497	INTERFACE INLINE int	482	INTERFACE int
498	is_promise (pointer p)	483	is_promise (pointer p)
499	{	484	{
500	return type (p) == T_PROMISE;	485	return type (p) == T_PROMISE;
501	}	486	}
502		487
503	INTERFACE INLINE int	488	INTERFACE int
504	is_environment (pointer p)	489	is_environment (pointer p)
505	{	490	{
506	return type (p) == T_ENVIRONMENT;	491	return type (p) == T_ENVIRONMENT;
507	}	492	}
508		493
…		…
514		499
515	#define is_mark(p) (typeflag (p) & T_MARK)	500	#define is_mark(p) (typeflag (p) & T_MARK)
516	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)	501	#define setmark(p) set_typeflag ((p), typeflag (p) \| T_MARK)
517	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	502	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
518		503
519	INTERFACE INLINE int	504	INTERFACE int
520	is_immutable (pointer p)	505	is_immutable (pointer p)
521	{	506	{
522	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	507	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
523	}	508	}
524		509
525	INTERFACE INLINE void	510	INTERFACE void
526	setimmutable (pointer p)	511	setimmutable (pointer p)
527	{	512	{
528	#if USE_ERROR_CHECKING	513	#if USE_ERROR_CHECKING
529	set_typeflag (p, typeflag (p) \| T_IMMUTABLE);	514	set_typeflag (p, typeflag (p) \| T_IMMUTABLE);
530	#endif	515	#endif
531	}	516	}
532		517
533	#if USE_CHAR_CLASSIFIERS	518	#if USE_CHAR_CLASSIFIERS
534	static INLINE int	519	ecb_inline int
535	Cisalpha (int c)	520	Cisalpha (int c)
536	{	521	{
537	return isascii (c) && isalpha (c);	522	return isascii (c) && isalpha (c);
538	}	523	}
539		524
540	static INLINE int	525	ecb_inline int
541	Cisdigit (int c)	526	Cisdigit (int c)
542	{	527	{
543	return isascii (c) && isdigit (c);	528	return isascii (c) && isdigit (c);
544	}	529	}
545		530
546	static INLINE int	531	ecb_inline int
547	Cisspace (int c)	532	Cisspace (int c)
548	{	533	{
549	return isascii (c) && isspace (c);	534	return isascii (c) && isspace (c);
550	}	535	}
551		536
552	static INLINE int	537	ecb_inline int
553	Cisupper (int c)	538	Cisupper (int c)
554	{	539	{
555	return isascii (c) && isupper (c);	540	return isascii (c) && isupper (c);
556	}	541	}
557		542
558	static INLINE int	543	ecb_inline int
559	Cislower (int c)	544	Cislower (int c)
560	{	545	{
561	return isascii (c) && islower (c);	546	return isascii (c) && islower (c);
562	}	547	}
563	#endif	548	#endif
…		…
624	#endif	609	#endif
625		610
626	static int file_push (SCHEME_P_ const char *fname);	611	static int file_push (SCHEME_P_ const char *fname);
627	static void file_pop (SCHEME_P);	612	static void file_pop (SCHEME_P);
628	static int file_interactive (SCHEME_P);	613	static int file_interactive (SCHEME_P);
629	static INLINE int is_one_of (char *s, int c);	614	ecb_inline int is_one_of (char *s, int c);
630	static int alloc_cellseg (SCHEME_P_ int n);	615	static int alloc_cellseg (SCHEME_P_ int n);
631	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);	616	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
632	static void finalize_cell (SCHEME_P_ pointer a);	617	static void finalize_cell (SCHEME_P_ pointer a);
633	static int count_consecutive_cells (pointer x, int needed);	618	static int count_consecutive_cells (pointer x, int needed);
634	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);
635	static pointer mk_number (SCHEME_P_ const num n);	620	static pointer mk_number (SCHEME_P_ const num n);
636	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);
…		…
653	static int basic_inchar (port *pt);	638	static int basic_inchar (port *pt);
654	static int inchar (SCHEME_P);	639	static int inchar (SCHEME_P);
655	static void backchar (SCHEME_P_ int c);	640	static void backchar (SCHEME_P_ int c);
656	static char readstr_upto (SCHEME_P_ char delim);	641	static char readstr_upto (SCHEME_P_ char delim);
657	static pointer readstrexp (SCHEME_P);	642	static pointer readstrexp (SCHEME_P);
658	static INLINE int skipspace (SCHEME_P);	643	ecb_inline int skipspace (SCHEME_P);
659	static int token (SCHEME_P);	644	static int token (SCHEME_P);
660	static void printslashstring (SCHEME_P_ char *s, int len);	645	static void printslashstring (SCHEME_P_ char *s, int len);
661	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);
662	static void printatom (SCHEME_P_ pointer l, int f);	647	static void printatom (SCHEME_P_ pointer l, int f);
663	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	648	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
667	static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);	652	static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
668	static pointer revappend (SCHEME_P_ pointer a, pointer b);	653	static pointer revappend (SCHEME_P_ pointer a, pointer b);
669	static pointer ss_get_cont (SCHEME_P);	654	static pointer ss_get_cont (SCHEME_P);
670	static void ss_set_cont (SCHEME_P_ pointer cont);	655	static void ss_set_cont (SCHEME_P_ pointer cont);
671	static void dump_stack_mark (SCHEME_P);	656	static void dump_stack_mark (SCHEME_P);
672	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);
673	static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op);	659	static int opexe_2 (SCHEME_P_ enum scheme_opcodes op);
674	static pointer opexe_r (SCHEME_P_ enum scheme_opcodes op);
675	static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op);	660	static int opexe_3 (SCHEME_P_ enum scheme_opcodes op);
676	static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op);	661	static int opexe_4 (SCHEME_P_ enum scheme_opcodes op);
677	static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op);	662	static int opexe_5 (SCHEME_P_ enum scheme_opcodes op);
678	static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op);	663	static int opexe_6 (SCHEME_P_ enum scheme_opcodes op);
679	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);	664	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
680	static void assign_syntax (SCHEME_P_ const char *name);	665	static void assign_syntax (SCHEME_P_ const char *name);
681	static int syntaxnum (pointer p);	666	static int syntaxnum (pointer p);
682	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);
683		668
…		…
781		766
782	num_set_ivalue (ret, res);	767	num_set_ivalue (ret, res);
783	return ret;	768	return ret;
784	}	769	}
785		770
786	/* this completely disrespects NaNs */	771	/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
787	static int	772	static int
788	num_cmp (num a, num b)	773	num_cmp (num a, num b)
789	{	774	{
790	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);	775	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
791	int ret;	776	int ret;
…		…
834	#endif	819	#endif
835		820
836	static int	821	static int
837	is_zero_rvalue (RVALUE x)	822	is_zero_rvalue (RVALUE x)
838	{	823	{
		824	return x == 0;
		825	#if 0
839	#if USE_REAL	826	#if USE_REAL
840	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. */
841	#else	828	#else
842	return x == 0;	829	return x == 0;
		830	#endif
843	#endif	831	#endif
844	}	832	}
845		833
846	/* allocate new cell segment */	834	/* allocate new cell segment */
847	static int	835	static int
…		…
919		907
920	return n;	908	return n;
921	}	909	}
922		910
923	/* get new cell. parameter a, b is marked by gc. */	911	/* get new cell. parameter a, b is marked by gc. */
924	static INLINE pointer	912	ecb_inline pointer
925	get_cell_x (SCHEME_P_ pointer a, pointer b)	913	get_cell_x (SCHEME_P_ pointer a, pointer b)
926	{	914	{
927	if (ecb_expect_false (SCHEME_V->free_cell == NIL))	915	if (ecb_expect_false (SCHEME_V->free_cell == NIL))
928	{	916	{
929	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	917	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
…		…
1007	push_recent_alloc (SCHEME_A_ v, NIL);	995	push_recent_alloc (SCHEME_A_ v, NIL);
1008		996
1009	return v;	997	return v;
1010	}	998	}
1011		999
1012	static INLINE void	1000	ecb_inline void
1013	ok_to_freely_gc (SCHEME_P)	1001	ok_to_freely_gc (SCHEME_P)
1014	{	1002	{
1015	set_car (S_SINK, NIL);	1003	set_car (S_SINK, NIL);
1016	}	1004	}
1017		1005
…		…
1081	location = hash_fn (name, veclength (SCHEME_V->oblist));	1069	location = hash_fn (name, veclength (SCHEME_V->oblist));
1082	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)));
1083	return x;	1071	return x;
1084	}	1072	}
1085		1073
1086	static INLINE pointer	1074	ecb_inline pointer
1087	oblist_find_by_name (SCHEME_P_ const char *name)	1075	oblist_find_by_name (SCHEME_P_ const char *name)
1088	{	1076	{
1089	int location;	1077	int location;
1090	pointer x;	1078	pointer x;
1091	char *s;	1079	char *s;
…		…
1124	oblist_initial_value (SCHEME_P)	1112	oblist_initial_value (SCHEME_P)
1125	{	1113	{
1126	return NIL;	1114	return NIL;
1127	}	1115	}
1128		1116
1129	static INLINE pointer	1117	ecb_inline pointer
1130	oblist_find_by_name (SCHEME_P_ const char *name)	1118	oblist_find_by_name (SCHEME_P_ const char *name)
1131	{	1119	{
1132	pointer x;	1120	pointer x;
1133	char *s;	1121	char *s;
1134		1122
…		…
2232	}	2220	}
2233	}	2221	}
2234	}	2222	}
2235		2223
2236	/* check c is in chars */	2224	/* check c is in chars */
2237	static INLINE int	2225	ecb_inline int
2238	is_one_of (char *s, int c)	2226	is_one_of (char *s, int c)
2239	{	2227	{
2240	if (c == EOF)	2228	if (c == EOF)
2241	return 1;	2229	return 1;
2242		2230
2243	return !!strchr (s, c);	2231	return !!strchr (s, c);
2244	}	2232	}
2245		2233
2246	/* skip white characters */	2234	/* skip white characters */
2247	static INLINE int	2235	ecb_inline int
2248	skipspace (SCHEME_P)	2236	skipspace (SCHEME_P)
2249	{	2237	{
2250	int c, curr_line = 0;	2238	int c, curr_line = 0;
2251		2239
2252	do	2240	do
…		…
2480	{	2468	{
2481	p = SCHEME_V->strbuff;	2469	p = SCHEME_V->strbuff;
2482		2470
2483	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 */
2484	{	2472	{
2485	if (num_is_integer (l))	2473	if (is_integer (l))
2486	xnum (p, ivalue_unchecked (l));	2474	xnum (p, ivalue_unchecked (l));
2487	#if USE_REAL	2475	#if USE_REAL
2488	else	2476	else
2489	{	2477	{
2490	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));	2478	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
…		…
2745	return 0;	2733	return 0;
2746	}	2734	}
2747	else if (is_number (a))	2735	else if (is_number (a))
2748	{	2736	{
2749	if (is_number (b))	2737	if (is_number (b))
2750	if (num_is_integer (a) == num_is_integer (b))
2751	return num_cmp (nvalue (a), nvalue (b)) == 0;	2738	return num_cmp (nvalue (a), nvalue (b)) == 0;
2752		2739
2753	return 0;	2740	return 0;
2754	}	2741	}
2755	else if (is_character (a))	2742	else if (is_character (a))
2756	{	2743	{
…		…
2823		2810
2824	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2811	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2825	setenvironment (SCHEME_V->envir);	2812	setenvironment (SCHEME_V->envir);
2826	}	2813	}
2827		2814
2828	static INLINE void	2815	ecb_inline void
2829	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)
2830	{	2817	{
2831	pointer slot = immutable_cons (variable, value);	2818	pointer slot = immutable_cons (variable, value);
2832		2819
2833	if (is_vector (car (env)))	2820	if (is_vector (car (env)))
…		…
2873	return NIL;	2860	return NIL;
2874	}	2861	}
2875		2862
2876	#else /* USE_ALIST_ENV */	2863	#else /* USE_ALIST_ENV */
2877		2864
2878	static INLINE void	2865	ecb_inline void
2879	new_frame_in_env (SCHEME_P_ pointer old_env)	2866	new_frame_in_env (SCHEME_P_ pointer old_env)
2880	{	2867	{
2881	SCHEME_V->envir = immutable_cons (NIL, old_env);	2868	SCHEME_V->envir = immutable_cons (NIL, old_env);
2882	setenvironment (SCHEME_V->envir);	2869	setenvironment (SCHEME_V->envir);
2883	}	2870	}
2884		2871
2885	static INLINE void	2872	ecb_inline void
2886	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)
2887	{	2874	{
2888	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2875	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2889	}	2876	}
2890		2877
…		…
2912	return NIL;	2899	return NIL;
2913	}	2900	}
2914		2901
2915	#endif /* USE_ALIST_ENV else */	2902	#endif /* USE_ALIST_ENV else */
2916		2903
2917	static INLINE void	2904	ecb_inline void
2918	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2905	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2919	{	2906	{
2920	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);
2921	}	2908	}
2922		2909
2923	static INLINE void	2910	ecb_inline void
2924	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2911	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2925	{	2912	{
2926	set_cdr (slot, value);	2913	set_cdr (slot, value);
2927	}	2914	}
2928		2915
2929	static INLINE pointer	2916	ecb_inline pointer
2930	slot_value_in_env (pointer slot)	2917	slot_value_in_env (pointer slot)
2931	{	2918	{
2932	return cdr (slot);	2919	return cdr (slot);
2933	}	2920	}
2934		2921
2935	/* ========== Evaluation Cycle ========== */	2922	/* ========== Evaluation Cycle ========== */
2936		2923
2937	static pointer	2924	static int
2938	xError_1 (SCHEME_P_ const char *s, pointer a)	2925	xError_1 (SCHEME_P_ const char *s, pointer a)
2939	{	2926	{
2940	#if USE_ERROR_HOOK	2927	#if USE_ERROR_HOOK
2941	pointer x;	2928	pointer x;
2942	pointer hdl = SCHEME_V->ERROR_HOOK;	2929	pointer hdl = SCHEME_V->ERROR_HOOK;
…		…
2977	code = cons (mk_string (SCHEME_A_ s), code);	2964	code = cons (mk_string (SCHEME_A_ s), code);
2978	setimmutable (car (code));	2965	setimmutable (car (code));
2979	SCHEME_V->code = cons (slot_value_in_env (x), code);	2966	SCHEME_V->code = cons (slot_value_in_env (x), code);
2980	SCHEME_V->op = OP_EVAL;	2967	SCHEME_V->op = OP_EVAL;
2981		2968
2982	return S_T;	2969	return 0;
2983	}	2970	}
2984	#endif	2971	#endif
2985		2972
2986	if (a)	2973	if (a)
2987	SCHEME_V->args = cons (a, NIL);	2974	SCHEME_V->args = cons (a, NIL);
…		…
2989	SCHEME_V->args = NIL;	2976	SCHEME_V->args = NIL;
2990		2977
2991	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);
2992	setimmutable (car (SCHEME_V->args));	2979	setimmutable (car (SCHEME_V->args));
2993	SCHEME_V->op = OP_ERR0;	2980	SCHEME_V->op = OP_ERR0;
		2981
2994	return S_T;	2982	return 0;
2995	}	2983	}
2996		2984
2997	#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)
2998	#define Error_0(s) Error_1 (s, 0)	2986	#define Error_0(s) Error_1 (s, 0)
2999		2987
3000	/* Too small to turn into function */	2988	/* Too small to turn into function */
3001	#define BEGIN do {	2989	#define BEGIN do {
3002	#define END } while (0)	2990	#define END } while (0)
3003	#define s_goto(a) BEGIN \	2991	#define s_goto(a) BEGIN \
3004	SCHEME_V->op = a; \	2992	SCHEME_V->op = a; \
3005	return S_T; END	2993	return 0; END
3006		2994
3007	#define s_return(a) return xs_return (SCHEME_A_ a)	2995	#define s_return(a) return xs_return (SCHEME_A_ a)
3008		2996
3009	#ifndef USE_SCHEME_STACK	2997	#ifndef USE_SCHEME_STACK
3010		2998
…		…
3040	next_frame->code = code;	3028	next_frame->code = code;
3041		3029
3042	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);	3030	SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3043	}	3031	}
3044		3032
3045	static pointer	3033	static int
3046	xs_return (SCHEME_P_ pointer a)	3034	xs_return (SCHEME_P_ pointer a)
3047	{	3035	{
3048	int nframes = (uintptr_t)SCHEME_V->dump;	3036	int nframes = (uintptr_t)SCHEME_V->dump;
3049	struct dump_stack_frame *frame;	3037	struct dump_stack_frame *frame;
3050		3038
3051	SCHEME_V->value = a;	3039	SCHEME_V->value = a;
3052		3040
3053	if (nframes <= 0)	3041	if (nframes <= 0)
3054	return NIL;	3042	return -1;
3055		3043
3056	frame = &SCHEME_V->dump_base[--nframes];	3044	frame = &SCHEME_V->dump_base[--nframes];
3057	SCHEME_V->op = frame->op;	3045	SCHEME_V->op = frame->op;
3058	SCHEME_V->args = frame->args;	3046	SCHEME_V->args = frame->args;
3059	SCHEME_V->envir = frame->envir;	3047	SCHEME_V->envir = frame->envir;
3060	SCHEME_V->code = frame->code;	3048	SCHEME_V->code = frame->code;
3061	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3049	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3062		3050
3063	return S_T;	3051	return 0;
3064	}	3052	}
3065		3053
3066	static INLINE void	3054	ecb_inline void
3067	dump_stack_reset (SCHEME_P)	3055	dump_stack_reset (SCHEME_P)
3068	{	3056	{
3069	/* 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 */
3070	SCHEME_V->dump = (pointer)+0;	3058	SCHEME_V->dump = (pointer)+0;
3071	}	3059	}
3072		3060
3073	static INLINE void	3061	ecb_inline void
3074	dump_stack_initialize (SCHEME_P)	3062	dump_stack_initialize (SCHEME_P)
3075	{	3063	{
3076	SCHEME_V->dump_size = 0;	3064	SCHEME_V->dump_size = 0;
3077	SCHEME_V->dump_base = 0;	3065	SCHEME_V->dump_base = 0;
3078	dump_stack_reset (SCHEME_A);	3066	dump_stack_reset (SCHEME_A);
…		…
3145	SCHEME_V->dump = (pointer)(uintptr_t)i;	3133	SCHEME_V->dump = (pointer)(uintptr_t)i;
3146	}	3134	}
3147		3135
3148	#else	3136	#else
3149		3137
3150	static INLINE void	3138	ecb_inline void
3151	dump_stack_reset (SCHEME_P)	3139	dump_stack_reset (SCHEME_P)
3152	{	3140	{
3153	SCHEME_V->dump = NIL;	3141	SCHEME_V->dump = NIL;
3154	}	3142	}
3155		3143
3156	static INLINE void	3144	ecb_inline void
3157	dump_stack_initialize (SCHEME_P)	3145	dump_stack_initialize (SCHEME_P)
3158	{	3146	{
3159	dump_stack_reset (SCHEME_A);	3147	dump_stack_reset (SCHEME_A);
3160	}	3148	}
3161		3149
…		…
3163	dump_stack_free (SCHEME_P)	3151	dump_stack_free (SCHEME_P)
3164	{	3152	{
3165	SCHEME_V->dump = NIL;	3153	SCHEME_V->dump = NIL;
3166	}	3154	}
3167		3155
3168	static pointer	3156	static int
3169	xs_return (SCHEME_P_ pointer a)	3157	xs_return (SCHEME_P_ pointer a)
3170	{	3158	{
3171	pointer dump = SCHEME_V->dump;	3159	pointer dump = SCHEME_V->dump;
3172		3160
3173	SCHEME_V->value = a;	3161	SCHEME_V->value = a;
3174		3162
3175	if (dump == NIL)	3163	if (dump == NIL)
3176	return NIL;	3164	return -1;
3177		3165
3178	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);	3166	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);
3179	SCHEME_V->args = car (dump) ; dump = cdr (dump);	3167	SCHEME_V->args = car (dump) ; dump = cdr (dump);
3180	SCHEME_V->envir = car (dump) ; dump = cdr (dump);	3168	SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3181	SCHEME_V->code = car (dump) ; dump = cdr (dump);	3169	SCHEME_V->code = car (dump) ; dump = cdr (dump);
3182		3170
3183	SCHEME_V->dump = dump;	3171	SCHEME_V->dump = dump;
3184		3172
3185	return S_T;	3173	return 0;
3186	}	3174	}
3187		3175
3188	static void	3176	static void
3189	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)
3190	{	3178	{
…		…
3215		3203
3216	#endif	3204	#endif
3217		3205
3218	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)	3206	#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3219		3207
3220	static pointer	3208	static int
3221	opexe_0 (SCHEME_P_ enum scheme_opcodes op)	3209	opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3222	{	3210	{
3223	pointer args = SCHEME_V->args;	3211	pointer args = SCHEME_V->args;
3224	pointer x, y;	3212	pointer x, y;
3225		3213
…		…
3911	SCHEME_V->code = car (args);	3899	SCHEME_V->code = car (args);
3912	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);
3913	s_goto (OP_APPLY);	3901	s_goto (OP_APPLY);
3914	}	3902	}
3915		3903
3916	abort ();	3904	if (USE_ERROR_CHECKING) abort ();
3917	}	3905	}
3918		3906
3919	static pointer	3907	static int
3920	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	3908	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3921	{	3909	{
3922	pointer args = SCHEME_V->args;	3910	pointer args = SCHEME_V->args;
3923	pointer x = car (args);	3911	pointer x = car (args);
3924	num v;	3912	num v;
3925		3913
…		…
3929		3917
3930	switch (op)	3918	switch (op)
3931	{	3919	{
3932	#if USE_MATH	3920	#if USE_MATH
3933	case OP_INEX2EX: /* inexact->exact */	3921	case OP_INEX2EX: /* inexact->exact */
3934	if (num_is_integer (x))	3922	if (is_integer (x))
3935	s_return (x);	3923	s_return (x);
3936	else if (modf (rvalue_unchecked (x), &dd) == 0)	3924	else if (modf (rvalue_unchecked (x), &dd) == 0)
3937	s_return (mk_integer (SCHEME_A_ ivalue (x)));	3925	s_return (mk_integer (SCHEME_A_ ivalue (x)));
3938	else	3926	else
3939	Error_1 ("inexact->exact: not integral:", x);	3927	Error_1 ("inexact->exact: not integral:", x);
…		…
3962	{	3950	{
3963	RVALUE result;	3951	RVALUE result;
3964	int real_result = 1;	3952	int real_result = 1;
3965	pointer y = cadr (args);	3953	pointer y = cadr (args);
3966		3954
3967	if (num_is_integer (x) && num_is_integer (y))	3955	if (is_integer (x) && is_integer (y))
3968	real_result = 0;	3956	real_result = 0;
3969		3957
3970	/* This 'if' is an R5RS compatibility fix. */	3958	/* This 'if' is an R5RS compatibility fix. */
3971	/* NOTE: Remove this 'if' fix for R6RS. */	3959	/* NOTE: Remove this 'if' fix for R6RS. */
3972	if (rvalue (x) == 0 && rvalue (y) < 0)	3960	if (rvalue (x) == 0 && rvalue (y) < 0)
…		…
4014		4002
4015	case OP_ADD: /* + */	4003	case OP_ADD: /* + */
4016	v = num_zero;	4004	v = num_zero;
4017		4005
4018	for (x = args; x != NIL; x = cdr (x))	4006	for (x = args; x != NIL; x = cdr (x))
4019	v = num_op ('+', v, nvalue (car (x)));	4007	v = num_op (NUM_ADD, v, nvalue (car (x)));
4020		4008
4021	s_return (mk_number (SCHEME_A_ v));	4009	s_return (mk_number (SCHEME_A_ v));
4022		4010
4023	case OP_MUL: /* * */	4011	case OP_MUL: /* * */
4024	v = num_one;	4012	v = num_one;
4025		4013
4026	for (x = args; x != NIL; x = cdr (x))	4014	for (x = args; x != NIL; x = cdr (x))
4027	v = num_op ('+', v, nvalue (car (x)));	4015	v = num_op (NUM_MUL, v, nvalue (car (x)));
4028		4016
4029	s_return (mk_number (SCHEME_A_ v));	4017	s_return (mk_number (SCHEME_A_ v));
4030		4018
4031	case OP_SUB: /* - */	4019	case OP_SUB: /* - */
4032	if (cdr (args) == NIL)	4020	if (cdr (args) == NIL)
…		…
4039	x = cdr (args);	4027	x = cdr (args);
4040	v = nvalue (car (args));	4028	v = nvalue (car (args));
4041	}	4029	}
4042		4030
4043	for (; x != NIL; x = cdr (x))	4031	for (; x != NIL; x = cdr (x))
4044	v = num_op ('+', v, nvalue (car (x)));	4032	v = num_op (NUM_SUB, v, nvalue (car (x)));
4045		4033
4046	s_return (mk_number (SCHEME_A_ v));	4034	s_return (mk_number (SCHEME_A_ v));
4047		4035
4048	case OP_DIV: /* / */	4036	case OP_DIV: /* / */
4049	if (cdr (args) == NIL)	4037	if (cdr (args) == NIL)
…		…
4056	x = cdr (args);	4044	x = cdr (args);
4057	v = nvalue (car (args));	4045	v = nvalue (car (args));
4058	}	4046	}
4059		4047
4060	for (; x != NIL; x = cdr (x))	4048	for (; x != NIL; x = cdr (x))
4061	{
4062	if (!is_zero_rvalue (rvalue (car (x))))	4049	if (!is_zero_rvalue (rvalue (car (x))))
4063	v = num_div (v, nvalue (car (x)));	4050	v = num_div (v, nvalue (car (x)));
4064	else	4051	else
4065	Error_0 ("/: division by zero");	4052	Error_0 ("/: division by zero");
4066	}
4067		4053
4068	s_return (mk_number (SCHEME_A_ v));	4054	s_return (mk_number (SCHEME_A_ v));
4069		4055
4070	case OP_INTDIV: /* quotient */	4056	case OP_INTDIV: /* quotient */
4071	if (cdr (args) == NIL)	4057	if (cdr (args) == NIL)
…		…
4080	}	4066	}
4081		4067
4082	for (; x != NIL; x = cdr (x))	4068	for (; x != NIL; x = cdr (x))
4083	{	4069	{
4084	if (ivalue (car (x)) != 0)	4070	if (ivalue (car (x)) != 0)
4085	v = num_op ('/', v, nvalue (car (x)));	4071	v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4086	else	4072	else
4087	Error_0 ("quotient: division by zero");	4073	Error_0 ("quotient: division by zero");
4088	}	4074	}
4089		4075
4090	s_return (mk_number (SCHEME_A_ v));	4076	s_return (mk_number (SCHEME_A_ v));
…		…
4418	set_vector_elem (x, index, caddr (args));	4404	set_vector_elem (x, index, caddr (args));
4419	s_return (x);	4405	s_return (x);
4420	}	4406	}
4421	}	4407	}
4422		4408
4423	return S_T;	4409	if (USE_ERROR_CHECKING) abort ();
4424	}	4410	}
4425		4411
4426	INTERFACE int	4412	INTERFACE int
4427	is_list (SCHEME_P_ pointer a)	4413	is_list (SCHEME_P_ pointer a)
4428	{	4414	{
…		…
4475	return -1;	4461	return -1;
4476	}	4462	}
4477	}	4463	}
4478	}	4464	}
4479		4465
4480	static pointer	4466	static int
4481	opexe_r (SCHEME_P_ enum scheme_opcodes op)	4467	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4482	{	4468	{
4483	pointer x = SCHEME_V->args;	4469	pointer x = SCHEME_V->args;
4484		4470
4485	for (;;)	4471	for (;;)
4486	{	4472	{
…		…
4506	}	4492	}
4507		4493
4508	s_return (S_T);	4494	s_return (S_T);
4509	}	4495	}
4510		4496
4511	static pointer	4497	static int
4512	opexe_3 (SCHEME_P_ enum scheme_opcodes op)	4498	opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4513	{	4499	{
4514	pointer args = SCHEME_V->args;	4500	pointer args = SCHEME_V->args;
4515	pointer a = car (args);	4501	pointer a = car (args);
4516	pointer d = cdr (args);	4502	pointer d = cdr (args);
…		…
4562	}	4548	}
4563		4549
4564	s_retbool (r);	4550	s_retbool (r);
4565	}	4551	}
4566		4552
4567	static pointer	4553	static int
4568	opexe_4 (SCHEME_P_ enum scheme_opcodes op)	4554	opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4569	{	4555	{
4570	pointer args = SCHEME_V->args;	4556	pointer args = SCHEME_V->args;
4571	pointer a = car (args);	4557	pointer a = car (args);
4572	pointer x, y;	4558	pointer x, y;
…		…
4658	putstr (SCHEME_A_ "\n");	4644	putstr (SCHEME_A_ "\n");
4659		4645
4660	if (SCHEME_V->interactive_repl)	4646	if (SCHEME_V->interactive_repl)
4661	s_goto (OP_T0LVL);	4647	s_goto (OP_T0LVL);
4662	else	4648	else
4663	return NIL;	4649	return -1;
4664	}	4650	}
4665		4651
4666	case OP_REVERSE: /* reverse */	4652	case OP_REVERSE: /* reverse */
4667	s_return (reverse (SCHEME_A_ a));	4653	s_return (reverse (SCHEME_A_ a));
4668		4654
…		…
4725		4711
4726	case OP_QUIT: /* quit */	4712	case OP_QUIT: /* quit */
4727	if (is_pair (args))	4713	if (is_pair (args))
4728	SCHEME_V->retcode = ivalue (a);	4714	SCHEME_V->retcode = ivalue (a);
4729		4715
4730	return NIL;	4716	return -1;
4731		4717
4732	case OP_GC: /* gc */	4718	case OP_GC: /* gc */
4733	gc (SCHEME_A_ NIL, NIL);	4719	gc (SCHEME_A_ NIL, NIL);
4734	s_return (S_T);	4720	s_return (S_T);
4735		4721
…		…
4782	break;	4768	break;
4783	}	4769	}
4784		4770
4785	p = port_from_filename (SCHEME_A_ strvalue (a), prop);	4771	p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4786		4772
4787	if (p == NIL)	4773	s_return (p == NIL ? S_F : p);
4788	s_return (S_F);
4789
4790	s_return (p);
4791	}	4774	}
4792		4775
4793	# if USE_STRING_PORTS	4776	# if USE_STRING_PORTS
4794		4777
4795	case OP_OPEN_INSTRING: /* open-input-string */	4778	case OP_OPEN_INSTRING: /* open-input-string */
…		…
4810	}	4793	}
4811		4794
4812	p = port_from_string (SCHEME_A_ strvalue (a),	4795	p = port_from_string (SCHEME_A_ strvalue (a),
4813	strvalue (a) + strlength (a), prop);	4796	strvalue (a) + strlength (a), prop);
4814		4797
4815	if (p == NIL)	4798	s_return (p == NIL ? S_F : p);
4816	s_return (S_F);
4817
4818	s_return (p);
4819	}	4799	}
4820		4800
4821	case OP_OPEN_OUTSTRING: /* open-output-string */	4801	case OP_OPEN_OUTSTRING: /* open-output-string */
4822	{	4802	{
4823	pointer p;	4803	pointer p;
4824		4804
4825	if (a == NIL)	4805	if (a == NIL)
4826	{
4827	p = port_from_scratch (SCHEME_A);	4806	p = port_from_scratch (SCHEME_A);
4828
4829	if (p == NIL)
4830	s_return (S_F);
4831	}
4832	else	4807	else
4833	{
4834	p = port_from_string (SCHEME_A_ strvalue (a),	4808	p = port_from_string (SCHEME_A_ strvalue (a),
4835	strvalue (a) + strlength (a), port_output);	4809	strvalue (a) + strlength (a), port_output);
4836		4810
4837	if (p == NIL)	4811	s_return (p == NIL ? S_F : p);
4838	s_return (S_F);
4839	}
4840
4841	s_return (p);
4842	}	4812	}
4843		4813
4844	case OP_GET_OUTSTRING: /* get-output-string */	4814	case OP_GET_OUTSTRING: /* get-output-string */
4845	{	4815	{
4846	port *p;	4816	port *p;
…		…
4885	case OP_CURR_ENV: /* current-environment */	4855	case OP_CURR_ENV: /* current-environment */
4886	s_return (SCHEME_V->envir);	4856	s_return (SCHEME_V->envir);
4887		4857
4888	}	4858	}
4889		4859
4890	abort ();	4860	if (USE_ERROR_CHECKING) abort ();
4891	}	4861	}
4892		4862
4893	static pointer	4863	static int
4894	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4864	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4895	{	4865	{
4896	pointer args = SCHEME_V->args;	4866	pointer args = SCHEME_V->args;
4897	pointer x;	4867	pointer x;
4898		4868
…		…
5228	s_goto (OP_P0LIST);	5198	s_goto (OP_P0LIST);
5229	}	5199	}
5230	}	5200	}
5231	}	5201	}
5232		5202
5233	abort ();	5203	if (USE_ERROR_CHECKING) abort ();
5234	}	5204	}
5235		5205
5236	static pointer	5206	static int
5237	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5207	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5238	{	5208	{
5239	pointer args = SCHEME_V->args;	5209	pointer args = SCHEME_V->args;
5240	pointer a = car (args);	5210	pointer a = car (args);
5241	pointer x, y;	5211	pointer x, y;
…		…
5291		5261
5292	case OP_MACROP: /* macro? */	5262	case OP_MACROP: /* macro? */
5293	s_retbool (is_macro (a));	5263	s_retbool (is_macro (a));
5294	}	5264	}
5295		5265
5296	abort ();	5266	if (USE_ERROR_CHECKING) abort ();
5297	}	5267	}
5298		5268
		5269	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5299	typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes);	5270	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5300		5271
5301	typedef int (*test_predicate)(pointer);	5272	typedef int (*test_predicate)(pointer);
5302	static int	5273	static int
5303	is_any (pointer p)	5274	is_any (pointer p)
5304	{	5275	{
…		…
5338	{ is_number, "number" },	5309	{ is_number, "number" },
5339	{ is_integer, "integer" },	5310	{ is_integer, "integer" },
5340	{ is_nonneg, "non-negative integer" }	5311	{ is_nonneg, "non-negative integer" }
5341	};	5312	};
5342		5313
5343	#define TST_NONE 0 /* TST_NONE used for standard procedures, for internal ops, 0 is used */	5314	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5344	#define TST_ANY "\001"	5315	#define TST_ANY "\001"
5345	#define TST_STRING "\002"	5316	#define TST_STRING "\002"
5346	#define TST_SYMBOL "\003"	5317	#define TST_SYMBOL "\003"
5347	#define TST_PORT "\004"	5318	#define TST_PORT "\004"
5348	#define TST_INPORT "\005"	5319	#define TST_INPORT "\005"
…		…
5354	#define TST_VECTOR "\013"	5325	#define TST_VECTOR "\013"
5355	#define TST_NUMBER "\014"	5326	#define TST_NUMBER "\014"
5356	#define TST_INTEGER "\015"	5327	#define TST_INTEGER "\015"
5357	#define TST_NATURAL "\016"	5328	#define TST_NATURAL "\016"
5358		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	}
		5356
5359	typedef struct	5357	typedef struct
5360	{	5358	{
5361	dispatch_func func;	5359	uint8_t func;
5362	char *name;	5360	/dispatch_func func;//TODO: maybe optionally keep the pointer, for speed? /
		5361	uint8_t builtin;
5363	int min_arity;	5362	uint8_t min_arity;
5364	int max_arity;	5363	uint8_t max_arity;
5365	char arg_tests_encoding[3];	5364	char arg_tests_encoding[3];
5366	} op_code_info;	5365	} op_code_info;
5367		5366
5368	#define INF_ARG 0xffff
5369
5370	static op_code_info dispatch_table[] = {	5367	static const op_code_info dispatch_table[] = {
5371	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { opexe_ ## func, name, minarity, maxarity, argtest },	5368	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
5372	#include "opdefines.h"	5369	#include "opdefines.h"
5373	#undef OP_DEF	5370	#undef OP_DEF
5374	{0}	5371	{0}
5375	};	5372	};
5376		5373
5377	static const char *
5378	procname (pointer x)
5379	{
5380	int n = procnum (x);
5381	const char *name = dispatch_table[n].name;
5382
5383	if (name == 0)
5384	name = "ILLEGAL!";
5385
5386	return name;
5387	}
5388
5389	/* kernel of this interpreter */	5374	/* kernel of this interpreter */
5390	static void	5375	static void ecb_hot
5391	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5376	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5392	{	5377	{
5393	SCHEME_V->op = op;	5378	SCHEME_V->op = op;
5394		5379
5395	for (;;)	5380	for (;;)
5396	{	5381	{
5397	op_code_info *pcd = dispatch_table + SCHEME_V->op;	5382	const op_code_info *pcd = dispatch_table + SCHEME_V->op;
5398		5383
5399	#if USE_ERROR_CHECKING	5384	#if USE_ERROR_CHECKING
5400	if (pcd->name) /* if built-in function, check arguments */	5385	if (pcd->builtin) /* if built-in function, check arguments */
5401	{	5386	{
5402	int ok = 1;
5403	char msg[STRBUFFSIZE];	5387	char msg[STRBUFFSIZE];
5404	int n = list_length (SCHEME_A_ SCHEME_V->args);	5388	int n = list_length (SCHEME_A_ SCHEME_V->args);
5405		5389
5406	/* Check number of arguments */	5390	/* Check number of arguments */
5407	if (ecb_expect_false (n < pcd->min_arity))	5391	if (ecb_expect_false (n < pcd->min_arity))
5408	{	5392	{
5409	ok = 0;
5410	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5393	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5411	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;
5412	}	5397	}
5413	else if (ecb_expect_false (n > pcd->max_arity))	5398	else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
5414	{	5399	{
5415	ok = 0;
5416	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",	5400	snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5417	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;
5418	}	5404	}
5419		5405	else
5420	if (ecb_expect_false (ok))
5421	{	5406	{
5422	if (*pcd->arg_tests_encoding)	5407	if (pcd->arg_tests_encoding) / literal 0 and TST_NONE treated the same */
5423	{	5408	{
5424	int i = 0;	5409	int i = 0;
5425	int j;	5410	int j;
5426	const char *t = pcd->arg_tests_encoding;	5411	const char *t = pcd->arg_tests_encoding;
5427	pointer arglist = SCHEME_V->args;	5412	pointer arglist = SCHEME_V->args;
…		…
5443	}	5428	}
5444	while (i < n);	5429	while (i < n);
5445		5430
5446	if (i < n)	5431	if (i < n)
5447	{	5432	{
5448	ok = 0;
5449	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;
5450	}	5436	}
5451	}	5437	}
5452	}	5438	}
5453
5454	if (!ok)
5455	{
5456	if (xError_1 (SCHEME_A_ msg, 0) == NIL)
5457	return;
5458
5459	pcd = dispatch_table + SCHEME_V->op;
5460	}
5461	}	5439	}
5462	#endif	5440	#endif
5463		5441
5464	ok_to_freely_gc (SCHEME_A);	5442	ok_to_freely_gc (SCHEME_A);
5465		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
5466	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))
5467	return;	5455	return;
5468		5456
5469	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	5457	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5470	{	5458	{
5471	xwrstr ("No memory!\n");	5459	xwrstr ("No memory!\n");
…		…
5570	return OP_C0STREAM; /* cons-stream */	5558	return OP_C0STREAM; /* cons-stream */
5571	}	5559	}
5572	}	5560	}
5573		5561
5574	#if USE_MULTIPLICITY	5562	#if USE_MULTIPLICITY
5575	scheme *	5563	ecb_cold scheme *
5576	scheme_init_new ()	5564	scheme_init_new ()
5577	{	5565	{
5578	scheme *sc = malloc (sizeof (scheme));	5566	scheme *sc = malloc (sizeof (scheme));
5579		5567
5580	if (!scheme_init (SCHEME_A))	5568	if (!scheme_init (SCHEME_A))
…		…
5585	else	5573	else
5586	return sc;	5574	return sc;
5587	}	5575	}
5588	#endif	5576	#endif
5589		5577
5590	int	5578	ecb_cold int
5591	scheme_init (SCHEME_P)	5579	scheme_init (SCHEME_P)
5592	{	5580	{
5593	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	5581	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5594	pointer x;	5582	pointer x;
5595		5583
…		…
5668		5656
5669	for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)	5657	for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
5670	assign_syntax (SCHEME_A_ syntax_names[i]);	5658	assign_syntax (SCHEME_A_ syntax_names[i]);
5671	}	5659	}
5672		5660
		5661	// TODO: should iterate via strlen, to avoid n² complexity
5673	for (i = 0; i < n; i++)	5662	for (i = 0; i < n; i++)
5674	if (dispatch_table[i].name != 0)	5663	if (dispatch_table[i].builtin)
5675	assign_proc (SCHEME_A_ i, dispatch_table[i].name);	5664	assign_proc (SCHEME_A_ i, opname (i));
5676		5665
5677	/* initialization of global pointers to special symbols */	5666	/* initialization of global pointers to special symbols */
5678	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");	5667	SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5679	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");	5668	SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5680	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");	5669	SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
…		…
5719	scheme_set_external_data (SCHEME_P_ void *p)	5708	scheme_set_external_data (SCHEME_P_ void *p)
5720	{	5709	{
5721	SCHEME_V->ext_data = p;	5710	SCHEME_V->ext_data = p;
5722	}	5711	}
5723		5712
5724	void	5713	ecb_cold void
5725	scheme_deinit (SCHEME_P)	5714	scheme_deinit (SCHEME_P)
5726	{	5715	{
5727	int i;	5716	int i;
5728		5717
5729	#if SHOW_ERROR_LINE	5718	#if SHOW_ERROR_LINE

Diff Legend

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

Comparing cvsroot/microscheme/scheme.c (file contents): Revision 1.19 by root, Thu Nov 26 21:36:11 2015 UTC vs. Revision 1.25 by root, Fri Nov 27 04:37:26 2015 UTC

Diff Legend

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.19 by root, Thu Nov 26 21:36:11 2015 UTC vs.
Revision 1.25 by root, Fri Nov 27 04:37:26 2015 UTC