ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/microscheme/scheme.c

Comparing microscheme/scheme.c (file contents):
Revision 1.22 by root, Thu Nov 26 23:26:00 2015 UTC vs.
Revision 1.28 by root, Sat Nov 28 08:09:04 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
…		…
186	# define FIRST_CELLSEGS 3	182	# define FIRST_CELLSEGS 3
187	#endif	183	#endif
188		184
189	enum scheme_types	185	enum scheme_types
190	{	186	{
		187	T_INTEGER,
191	T_FREE,	188	T_REAL,
192	T_STRING,	189	T_STRING,
193	T_NUMBER,
194	T_SYMBOL,	190	T_SYMBOL,
195	T_PROC,	191	T_PROC,
196	T_PAIR,	192	T_PAIR, /* also used for free cells */
197	T_CLOSURE,	193	T_CLOSURE,
198	T_CONTINUATION,	194	T_CONTINUATION,
199	T_FOREIGN,	195	T_FOREIGN,
200	T_CHARACTER,	196	T_CHARACTER,
201	T_PORT,	197	T_PORT,
…		…
211	#define T_SYNTAX 0x0010	207	#define T_SYNTAX 0x0010
212	#define T_IMMUTABLE 0x0020	208	#define T_IMMUTABLE 0x0020
213	#define T_ATOM 0x0040 /* only for gc */	209	#define T_ATOM 0x0040 /* only for gc */
214	#define T_MARK 0x0080 /* only for gc */	210	#define T_MARK 0x0080 /* only for gc */
215		211
		212	/* num, for generic arithmetic */
		213	struct num
		214	{
		215	IVALUE ivalue;
		216	#if USE_REAL
		217	RVALUE rvalue;
		218	char is_fixnum;
		219	#endif
		220	};
		221
		222	#if USE_REAL
		223	# define num_is_fixnum(n) (n).is_fixnum
		224	# define num_set_fixnum(n,f) (n).is_fixnum = (f)
		225	# define num_ivalue(n) (n).ivalue
		226	# define num_rvalue(n) (n).rvalue
		227	# define num_set_ivalue(n,i) (n).rvalue = (n).ivalue = (i)
		228	# define num_set_rvalue(n,r) (n).rvalue = (r)
		229	#else
		230	# define num_is_fixnum(n) 1
		231	# define num_set_fixnum(n,f) 0
		232	# define num_ivalue(n) (n).ivalue
		233	# define num_rvalue(n) (n).ivalue
		234	# define num_set_ivalue(n,i) (n).ivalue = (i)
		235	# define num_set_rvalue(n,r) (n).ivalue = (r)
		236	#endif
		237
216	enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };	238	enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };
217		239
218	static num num_op (enum num_op op, num a, num b);	240	static num num_op (enum num_op op, num a, num b);
219	static num num_intdiv (num a, num b);	241	static num num_intdiv (num a, num b);
220	static num num_rem (num a, num b);	242	static num num_rem (num a, num b);
…		…
223	#if USE_MATH	245	#if USE_MATH
224	static double round_per_R5RS (double x);	246	static double round_per_R5RS (double x);
225	#endif	247	#endif
226	static int is_zero_rvalue (RVALUE x);	248	static int is_zero_rvalue (RVALUE x);
227		249
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;	250	static num num_zero;
235	static num num_one;	251	static num num_one;
236		252
237	/* macros for cell operations */	253	/* macros for cell operations */
238	#define typeflag(p) ((p)->flag + 0)	254	#define typeflag(p) ((p)->flag + 0)
239	#define set_typeflag(p,v) ((p)->flag = (v))	255	#define set_typeflag(p,v) ((p)->flag = (v))
240	#define type(p) (typeflag (p) & T_MASKTYPE)	256	#define type(p) (typeflag (p) & T_MASKTYPE)
241		257
242	INTERFACE INLINE int	258	INTERFACE int
243	is_string (pointer p)	259	is_string (pointer p)
244	{	260	{
245	return type (p) == T_STRING;	261	return type (p) == T_STRING;
246	}	262	}
247		263
248	#define strvalue(p) ((p)->object.string.svalue)	264	#define strvalue(p) ((p)->object.string.svalue)
249	#define strlength(p) ((p)->object.string.length)	265	#define strlength(p) ((p)->object.string.length)
250		266
251	INTERFACE int is_list (SCHEME_P_ pointer p);
252
253	INTERFACE INLINE int	267	INTERFACE int
254	is_vector (pointer p)	268	is_vector (pointer p)
255	{	269	{
256	return type (p) == T_VECTOR;	270	return type (p) == T_VECTOR;
257	}	271	}
258		272
259	#define vecvalue(p) ((p)->object.vector.vvalue)	273	#define vecvalue(p) ((p)->object.vector.vvalue)
260	#define veclength(p) ((p)->object.vector.length)	274	#define veclength(p) ((p)->object.vector.length)
261	INTERFACE void fill_vector (pointer vec, pointer obj);	275	INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
262	INTERFACE uint32_t vector_length (pointer vec);
263	INTERFACE pointer vector_elem (pointer vec, uint32_t ielem);	276	INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
264	INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a);	277	INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
265		278
266	INTERFACE uint32_t	279	INTERFACE int
267	vector_length (pointer vec)	280	is_integer (pointer p)
268	{	281	{
269	return vec->object.vector.length;	282	return type (p) == T_INTEGER;
270	}	283	}
271		284
		285	/* not the same as in scheme, where integers are (correctly :) reals */
272	INTERFACE INLINE int	286	INTERFACE int
		287	is_real (pointer p)
		288	{
		289	return type (p) == T_REAL;
		290	}
		291
		292	INTERFACE int
273	is_number (pointer p)	293	is_number (pointer p)
274	{	294	{
275	return type (p) == T_NUMBER;	295	return is_integer (p) || is_real (p);
276	}	296	}
277		297
278	INTERFACE INLINE int	298	INTERFACE int
279	is_integer (pointer p)
280	{
281	if (!is_number (p))
282	return 0;
283
284	if (num_is_integer (p) || ivalue (p) == rvalue (p))
285	return 1;
286
287	return 0;
288	}
289
290	INTERFACE INLINE int
291	is_real (pointer p)
292	{
293	return is_number (p) && !num_is_fixnum (p->object.number);
294	}
295
296	INTERFACE INLINE int
297	is_character (pointer p)	299	is_character (pointer p)
298	{	300	{
299	return type (p) == T_CHARACTER;	301	return type (p) == T_CHARACTER;
300	}	302	}
301		303
302	INTERFACE INLINE char *	304	INTERFACE char *
303	string_value (pointer p)	305	string_value (pointer p)
304	{	306	{
305	return strvalue (p);	307	return strvalue (p);
306	}	308	}
307		309
308	INLINE num
309	nvalue (pointer p)
310	{
311	return (p)->object.number;
312	}
313
314	static IVALUE
315	num_get_ivalue (const num n)
316	{
317	return num_is_fixnum (n) ? num_ivalue (n) : (IVALUE)num_rvalue (n);
318	}
319
320	static RVALUE
321	num_get_rvalue (const num n)
322	{
323	return num_is_fixnum (n) ? (RVALUE)num_ivalue (n) : num_rvalue (n);
324	}
325
326	INTERFACE IVALUE
327	ivalue (pointer p)
328	{
329	return num_get_ivalue (p->object.number);
330	}
331
332	INTERFACE RVALUE
333	rvalue (pointer p)
334	{
335	return num_get_rvalue (p->object.number);
336	}
337
338	#define ivalue_unchecked(p) ((p)->object.number.value.ivalue)	310	#define ivalue_unchecked(p) (p)->object.ivalue
		311	#define set_ivalue(p,v) (p)->object.ivalue = (v)
		312
339	#if USE_REAL	313	#if USE_REAL
340	# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)	314	#define rvalue_unchecked(p) (p)->object.rvalue
341	# define set_num_integer(p) (p)->object.number.is_fixnum=1;	315	#define set_rvalue(p,v) (p)->object.rvalue = (v)
342	# define set_num_real(p) (p)->object.number.is_fixnum=0;
343	#else	316	#else
344	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)	317	#define rvalue_unchecked(p) (p)->object.ivalue
345	# define set_num_integer(p) 0	318	#define set_rvalue(p,v) (p)->object.ivalue = (v)
346	# define set_num_real(p) 0
347	#endif	319	#endif
		320
348	INTERFACE long	321	INTERFACE long
349	charvalue (pointer p)	322	charvalue (pointer p)
350	{	323	{
351	return ivalue_unchecked (p);	324	return ivalue_unchecked (p);
352	}	325	}
353		326
354	INTERFACE INLINE int	327	INTERFACE int
355	is_port (pointer p)	328	is_port (pointer p)
356	{	329	{
357	return type (p) == T_PORT;	330	return type (p) == T_PORT;
358	}	331	}
359		332
360	INTERFACE INLINE int	333	INTERFACE int
361	is_inport (pointer p)	334	is_inport (pointer p)
362	{	335	{
363	return is_port (p) && p->object.port->kind & port_input;	336	return is_port (p) && p->object.port->kind & port_input;
364	}	337	}
365		338
366	INTERFACE INLINE int	339	INTERFACE int
367	is_outport (pointer p)	340	is_outport (pointer p)
368	{	341	{
369	return is_port (p) && p->object.port->kind & port_output;	342	return is_port (p) && p->object.port->kind & port_output;
370	}	343	}
371		344
372	INTERFACE INLINE int	345	INTERFACE int
373	is_pair (pointer p)	346	is_pair (pointer p)
374	{	347	{
375	return type (p) == T_PAIR;	348	return type (p) == T_PAIR;
376	}	349	}
377		350
…		…
409	pair_cdr (pointer p)	382	pair_cdr (pointer p)
410	{	383	{
411	return cdr (p);	384	return cdr (p);
412	}	385	}
413		386
414	INTERFACE INLINE int	387	INTERFACE int
415	is_symbol (pointer p)	388	is_symbol (pointer p)
416	{	389	{
417	return type (p) == T_SYMBOL;	390	return type (p) == T_SYMBOL;
418	}	391	}
419		392
420	INTERFACE INLINE char *	393	INTERFACE char *
421	symname (pointer p)	394	symname (pointer p)
422	{	395	{
423	return strvalue (car (p));	396	return strvalue (car (p));
424	}	397	}
425		398
426	#if USE_PLIST	399	#if USE_PLIST
427	SCHEME_EXPORT INLINE int	400	SCHEME_EXPORT int
428	hasprop (pointer p)	401	hasprop (pointer p)
429	{	402	{
430	return typeflag (p) & T_SYMBOL;	403	return typeflag (p) & T_SYMBOL;
431	}	404	}
432		405
433	# define symprop(p) cdr(p)	406	# define symprop(p) cdr(p)
434	#endif	407	#endif
435		408
436	INTERFACE INLINE int	409	INTERFACE int
437	is_syntax (pointer p)	410	is_syntax (pointer p)
438	{	411	{
439	return typeflag (p) & T_SYNTAX;	412	return typeflag (p) & T_SYNTAX;
440	}	413	}
441		414
442	INTERFACE INLINE int	415	INTERFACE int
443	is_proc (pointer p)	416	is_proc (pointer p)
444	{	417	{
445	return type (p) == T_PROC;	418	return type (p) == T_PROC;
446	}	419	}
447		420
448	INTERFACE INLINE int	421	INTERFACE int
449	is_foreign (pointer p)	422	is_foreign (pointer p)
450	{	423	{
451	return type (p) == T_FOREIGN;	424	return type (p) == T_FOREIGN;
452	}	425	}
453		426
454	INTERFACE INLINE char *	427	INTERFACE char *
455	syntaxname (pointer p)	428	syntaxname (pointer p)
456	{	429	{
457	return strvalue (car (p));	430	return strvalue (car (p));
458	}	431	}
459		432
460	#define procnum(p) ivalue (p)	433	#define procnum(p) ivalue_unchecked (p)
461	static const char *procname (pointer x);	434	static const char *procname (pointer x);
462		435
463	INTERFACE INLINE int	436	INTERFACE int
464	is_closure (pointer p)	437	is_closure (pointer p)
465	{	438	{
466	return type (p) == T_CLOSURE;	439	return type (p) == T_CLOSURE;
467	}	440	}
468		441
469	INTERFACE INLINE int	442	INTERFACE int
470	is_macro (pointer p)	443	is_macro (pointer p)
471	{	444	{
472	return type (p) == T_MACRO;	445	return type (p) == T_MACRO;
473	}	446	}
474		447
475	INTERFACE INLINE pointer	448	INTERFACE pointer
476	closure_code (pointer p)	449	closure_code (pointer p)
477	{	450	{
478	return car (p);	451	return car (p);
479	}	452	}
480		453
481	INTERFACE INLINE pointer	454	INTERFACE pointer
482	closure_env (pointer p)	455	closure_env (pointer p)
483	{	456	{
484	return cdr (p);	457	return cdr (p);
485	}	458	}
486		459
487	INTERFACE INLINE int	460	INTERFACE int
488	is_continuation (pointer p)	461	is_continuation (pointer p)
489	{	462	{
490	return type (p) == T_CONTINUATION;	463	return type (p) == T_CONTINUATION;
491	}	464	}
492		465
493	#define cont_dump(p) cdr (p)	466	#define cont_dump(p) cdr (p)
494	#define set_cont_dump(p,v) set_cdr ((p), (v))	467	#define set_cont_dump(p,v) set_cdr ((p), (v))
495		468
496	/* To do: promise should be forced ONCE only */	469	/* To do: promise should be forced ONCE only */
497	INTERFACE INLINE int	470	INTERFACE int
498	is_promise (pointer p)	471	is_promise (pointer p)
499	{	472	{
500	return type (p) == T_PROMISE;	473	return type (p) == T_PROMISE;
501	}	474	}
502		475
503	INTERFACE INLINE int	476	INTERFACE int
504	is_environment (pointer p)	477	is_environment (pointer p)
505	{	478	{
506	return type (p) == T_ENVIRONMENT;	479	return type (p) == T_ENVIRONMENT;
507	}	480	}
508		481
…		…
514		487
515	#define is_mark(p) (typeflag (p) & T_MARK)	488	#define is_mark(p) (typeflag (p) & T_MARK)
516	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)	489	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
517	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	490	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
518		491
519	INTERFACE INLINE int	492	INTERFACE int
520	is_immutable (pointer p)	493	is_immutable (pointer p)
521	{	494	{
522	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	495	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
523	}	496	}
524		497
525	INTERFACE INLINE void	498	INTERFACE void
526	setimmutable (pointer p)	499	setimmutable (pointer p)
527	{	500	{
528	#if USE_ERROR_CHECKING	501	#if USE_ERROR_CHECKING
529	set_typeflag (p, typeflag (p) | T_IMMUTABLE);	502	set_typeflag (p, typeflag (p) | T_IMMUTABLE);
530	#endif	503	#endif
531	}	504	}
532		505
		506	/* Result is:
		507	proper list: length
		508	circular list: -1
		509	not even a pair: -2
		510	dotted list: -2 minus length before dot
		511	*/
		512	INTERFACE int
		513	list_length (SCHEME_P_ pointer a)
		514	{
		515	int i = 0;
		516	pointer slow, fast;
		517
		518	slow = fast = a;
		519
		520	while (1)
		521	{
		522	if (fast == NIL)
		523	return i;
		524
		525	if (!is_pair (fast))
		526	return -2 - i;
		527
		528	fast = cdr (fast);
		529	++i;
		530
		531	if (fast == NIL)
		532	return i;
		533
		534	if (!is_pair (fast))
		535	return -2 - i;
		536
		537	++i;
		538	fast = cdr (fast);
		539
		540	/* Safe because we would have already returned if `fast'
		541	encountered a non-pair. */
		542	slow = cdr (slow);
		543
		544	if (fast == slow)
		545	{
		546	/* the fast pointer has looped back around and caught up
		547	with the slow pointer, hence the structure is circular,
		548	not of finite length, and therefore not a list */
		549	return -1;
		550	}
		551	}
		552	}
		553
		554	INTERFACE int
		555	is_list (SCHEME_P_ pointer a)
		556	{
		557	return list_length (SCHEME_A_ a) >= 0;
		558	}
		559
533	#if USE_CHAR_CLASSIFIERS	560	#if USE_CHAR_CLASSIFIERS
534	static INLINE int	561	ecb_inline int
535	Cisalpha (int c)	562	Cisalpha (int c)
536	{	563	{
537	return isascii (c) && isalpha (c);	564	return isascii (c) && isalpha (c);
538	}	565	}
539		566
540	static INLINE int	567	ecb_inline int
541	Cisdigit (int c)	568	Cisdigit (int c)
542	{	569	{
543	return isascii (c) && isdigit (c);	570	return isascii (c) && isdigit (c);
544	}	571	}
545		572
546	static INLINE int	573	ecb_inline int
547	Cisspace (int c)	574	Cisspace (int c)
548	{	575	{
549	return isascii (c) && isspace (c);	576	return isascii (c) && isspace (c);
550	}	577	}
551		578
552	static INLINE int	579	ecb_inline int
553	Cisupper (int c)	580	Cisupper (int c)
554	{	581	{
555	return isascii (c) && isupper (c);	582	return isascii (c) && isupper (c);
556	}	583	}
557		584
558	static INLINE int	585	ecb_inline int
559	Cislower (int c)	586	Cislower (int c)
560	{	587	{
561	return isascii (c) && islower (c);	588	return isascii (c) && islower (c);
562	}	589	}
563	#endif	590	#endif
…		…
624	#endif	651	#endif
625		652
626	static int file_push (SCHEME_P_ const char *fname);	653	static int file_push (SCHEME_P_ const char *fname);
627	static void file_pop (SCHEME_P);	654	static void file_pop (SCHEME_P);
628	static int file_interactive (SCHEME_P);	655	static int file_interactive (SCHEME_P);
629	static INLINE int is_one_of (char *s, int c);	656	ecb_inline int is_one_of (char *s, int c);
630	static int alloc_cellseg (SCHEME_P_ int n);	657	static int alloc_cellseg (SCHEME_P_ int n);
631	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);	658	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
632	static void finalize_cell (SCHEME_P_ pointer a);	659	static void finalize_cell (SCHEME_P_ pointer a);
633	static int count_consecutive_cells (pointer x, int needed);	660	static int count_consecutive_cells (pointer x, int needed);
634	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	661	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
635	static pointer mk_number (SCHEME_P_ const num n);	662	static pointer mk_number (SCHEME_P_ const num n);
636	static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);	663	static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
…		…
653	static int basic_inchar (port *pt);	680	static int basic_inchar (port *pt);
654	static int inchar (SCHEME_P);	681	static int inchar (SCHEME_P);
655	static void backchar (SCHEME_P_ int c);	682	static void backchar (SCHEME_P_ int c);
656	static char *readstr_upto (SCHEME_P_ char *delim);	683	static char *readstr_upto (SCHEME_P_ char *delim);
657	static pointer readstrexp (SCHEME_P);	684	static pointer readstrexp (SCHEME_P);
658	static INLINE int skipspace (SCHEME_P);	685	ecb_inline int skipspace (SCHEME_P);
659	static int token (SCHEME_P);	686	static int token (SCHEME_P);
660	static void printslashstring (SCHEME_P_ char *s, int len);	687	static void printslashstring (SCHEME_P_ char *s, int len);
661	static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);	688	static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
662	static void printatom (SCHEME_P_ pointer l, int f);	689	static void printatom (SCHEME_P_ pointer l, int f);
663	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	690	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
679	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);	706	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
680	static void assign_syntax (SCHEME_P_ const char *name);	707	static void assign_syntax (SCHEME_P_ const char *name);
681	static int syntaxnum (pointer p);	708	static int syntaxnum (pointer p);
682	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);	709	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
683		710
		711	static IVALUE
		712	ivalue (pointer x)
		713	{
		714	return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
		715	}
		716
		717	static RVALUE
		718	rvalue (pointer x)
		719	{
		720	return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
		721	}
		722
		723	INTERFACE num
		724	nvalue (pointer x)
		725	{
		726	num n;
		727
		728	num_set_fixnum (n, is_integer (x));
		729
		730	if (num_is_fixnum (n))
		731	num_set_ivalue (n, ivalue_unchecked (x));
		732	else
		733	num_set_rvalue (n, rvalue_unchecked (x));
		734
		735	return n;
		736	}
		737
684	static num	738	static num
685	num_op (enum num_op op, num a, num b)	739	num_op (enum num_op op, num a, num b)
686	{	740	{
687	num ret;	741	num ret;
688		742
689	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	743	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
690		744
691	if (num_is_fixnum (ret))	745	if (num_is_fixnum (ret))
692	{	746	{
693	IVALUE av = num_get_ivalue (a);
694	IVALUE bv = num_get_ivalue (b);
695
696	switch (op)	747	switch (op)
697	{	748	{
698	case NUM_ADD: av += bv; break;	749	case NUM_ADD: a.ivalue += b.ivalue; break;
699	case NUM_SUB: av -= bv; break;	750	case NUM_SUB: a.ivalue -= b.ivalue; break;
700	case NUM_MUL: av *= bv; break;	751	case NUM_MUL: a.ivalue *= b.ivalue; break;
701	case NUM_INTDIV: av /= bv; break;	752	case NUM_INTDIV: a.ivalue /= b.ivalue; break;
702	}	753	}
703		754
704	num_set_ivalue (ret, av);	755	num_set_ivalue (ret, a.ivalue);
705	}	756	}
		757	#if USE_REAL
706	else	758	else
707	{	759	{
708	RVALUE av = num_get_rvalue (a);
709	RVALUE bv = num_get_rvalue (b);
710
711	switch (op)	760	switch (op)
712	{	761	{
713	case NUM_ADD: av += bv; break;	762	case NUM_ADD: a.rvalue += b.rvalue; break;
714	case NUM_SUB: av -= bv; break;	763	case NUM_SUB: a.rvalue -= b.rvalue; break;
715	case NUM_MUL: av *= bv; break;	764	case NUM_MUL: a.rvalue *= b.rvalue; break;
716	case NUM_INTDIV: av /= bv; break;	765	case NUM_INTDIV: a.rvalue /= b.rvalue; break;
717	}	766	}
718		767
719	num_set_rvalue (ret, av);	768	num_set_rvalue (ret, a.rvalue);
720	}	769	}
		770	#endif
721		771
722	return ret;	772	return ret;
723	}	773	}
724		774
725	static num	775	static num
726	num_div (num a, num b)	776	num_div (num a, num b)
727	{	777	{
728	num ret;	778	num ret;
729		779
730	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0);	780	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0);
731		781
732	if (num_is_fixnum (ret))	782	if (num_is_fixnum (ret))
733	num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));	783	num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b));
734	else	784	else
735	num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));	785	num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b));
736		786
737	return ret;	787	return ret;
738	}	788	}
739		789
740	static num	790	static num
…		…
742	{	792	{
743	num ret;	793	num ret;
744	long e1, e2, res;	794	long e1, e2, res;
745		795
746	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	796	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
747	e1 = num_get_ivalue (a);	797	e1 = num_ivalue (a);
748	e2 = num_get_ivalue (b);	798	e2 = num_ivalue (b);
749	res = e1 % e2;	799	res = e1 % e2;
750		800
751	/* remainder should have same sign as second operand */	801	/* remainder should have same sign as second operand */
752	if (res > 0)	802	if (res > 0)
753	{	803	{
…		…
769	{	819	{
770	num ret;	820	num ret;
771	long e1, e2, res;	821	long e1, e2, res;
772		822
773	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	823	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
774	e1 = num_get_ivalue (a);	824	e1 = num_ivalue (a);
775	e2 = num_get_ivalue (b);	825	e2 = num_ivalue (b);
776	res = e1 % e2;	826	res = e1 % e2;
777		827
778	/* modulo should have same sign as second operand */	828	/* modulo should have same sign as second operand */
779	if (res * e2 < 0)	829	if (res * e2 < 0)
780	res += e2;	830	res += e2;
781		831
782	num_set_ivalue (ret, res);	832	num_set_ivalue (ret, res);
783	return ret;	833	return ret;
784	}	834	}
785		835
786	/* this completely disrespects NaNs */	836	/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
787	static int	837	static int
788	num_cmp (num a, num b)	838	num_cmp (num a, num b)
789	{	839	{
790	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);	840	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
791	int ret;	841	int ret;
792		842
793	if (is_fixnum)	843	if (is_fixnum)
794	{	844	{
795	IVALUE av = num_get_ivalue (a);	845	IVALUE av = num_ivalue (a);
796	IVALUE bv = num_get_ivalue (b);	846	IVALUE bv = num_ivalue (b);
797		847
798	ret = av == bv ? 0 : av < bv ? -1 : +1;	848	ret = av == bv ? 0 : av < bv ? -1 : +1;
799	}	849	}
800	else	850	else
801	{	851	{
802	RVALUE av = num_get_rvalue (a);	852	RVALUE av = num_rvalue (a);
803	RVALUE bv = num_get_rvalue (b);	853	RVALUE bv = num_rvalue (b);
804		854
805	ret = av == bv ? 0 : av < bv ? -1 : +1;	855	ret = av == bv ? 0 : av < bv ? -1 : +1;
806	}	856	}
807		857
808	return ret;	858	return ret;
…		…
834	#endif	884	#endif
835		885
836	static int	886	static int
837	is_zero_rvalue (RVALUE x)	887	is_zero_rvalue (RVALUE x)
838	{	888	{
		889	return x == 0;
		890	#if 0
839	#if USE_REAL	891	#if USE_REAL
840	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */	892	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
841	#else	893	#else
842	return x == 0;	894	return x == 0;
		895	#endif
843	#endif	896	#endif
844	}	897	}
845		898
846	/* allocate new cell segment */	899	/* allocate new cell segment */
847	static int	900	static int
…		…
868	return k;	921	return k;
869		922
870	i = ++SCHEME_V->last_cell_seg;	923	i = ++SCHEME_V->last_cell_seg;
871	SCHEME_V->alloc_seg[i] = cp;	924	SCHEME_V->alloc_seg[i] = cp;
872		925
873	/* insert new segment in address order */
874	newp = (pointer)cp;	926	newp = (pointer)cp;
875	SCHEME_V->cell_seg[i] = newp;	927	SCHEME_V->cell_seg[i] = newp;
876	SCHEME_V->cell_segsize[i] = segsize;	928	SCHEME_V->cell_segsize[i] = segsize;
877
878	//TODO: insert, not swap
879	while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i])
880	{
881	p = SCHEME_V->cell_seg[i];
882	SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1];
883	SCHEME_V->cell_seg[i - 1] = p;
884
885	k = SCHEME_V->cell_segsize[i];
886	SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1];
887	SCHEME_V->cell_segsize[i - 1] = k;
888
889	--i;
890	}
891
892	SCHEME_V->fcells += segsize;	929	SCHEME_V->fcells += segsize;
893	last = newp + segsize - 1;	930	last = newp + segsize - 1;
894		931
895	for (p = newp; p <= last; p++)	932	for (p = newp; p <= last; p++)
896	{	933	{
897	set_typeflag (p, T_FREE);	934	set_typeflag (p, T_PAIR);
898	set_car (p, NIL);	935	set_car (p, NIL);
899	set_cdr (p, p + 1);	936	set_cdr (p, p + 1);
900	}	937	}
901		938
902	/* insert new cells in address order on free list */
903	if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell)
904	{
905	set_cdr (last, SCHEME_V->free_cell);	939	set_cdr (last, SCHEME_V->free_cell);
906	SCHEME_V->free_cell = newp;	940	SCHEME_V->free_cell = newp;
907	}
908	else
909	{
910	p = SCHEME_V->free_cell;
911
912	while (cdr (p) != NIL && newp > cdr (p))
913	p = cdr (p);
914
915	set_cdr (last, cdr (p));
916	set_cdr (p, newp);
917	}
918	}	941	}
919		942
920	return n;	943	return n;
921	}	944	}
922		945
923	/* get new cell. parameter a, b is marked by gc. */	946	/* get new cell. parameter a, b is marked by gc. */
924	static INLINE pointer	947	ecb_inline pointer
925	get_cell_x (SCHEME_P_ pointer a, pointer b)	948	get_cell_x (SCHEME_P_ pointer a, pointer b)
926	{	949	{
927	if (ecb_expect_false (SCHEME_V->free_cell == NIL))	950	if (ecb_expect_false (SCHEME_V->free_cell == NIL))
928	{	951	{
929	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	952	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
…		…
1001	/* Record it as a vector so that gc understands it. */	1024	/* Record it as a vector so that gc understands it. */
1002	set_typeflag (v, T_VECTOR | T_ATOM);	1025	set_typeflag (v, T_VECTOR | T_ATOM);
1003		1026
1004	v->object.vector.vvalue = e;	1027	v->object.vector.vvalue = e;
1005	v->object.vector.length = len;	1028	v->object.vector.length = len;
1006	fill_vector (v, init);	1029	fill_vector (v, 0, init);
1007	push_recent_alloc (SCHEME_A_ v, NIL);	1030	push_recent_alloc (SCHEME_A_ v, NIL);
1008		1031
1009	return v;	1032	return v;
1010	}	1033	}
1011		1034
1012	static INLINE void	1035	ecb_inline void
1013	ok_to_freely_gc (SCHEME_P)	1036	ok_to_freely_gc (SCHEME_P)
1014	{	1037	{
1015	set_car (S_SINK, NIL);	1038	set_car (S_SINK, NIL);
1016	}	1039	}
1017		1040
…		…
1077	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);	1100	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1078	set_typeflag (x, T_SYMBOL);	1101	set_typeflag (x, T_SYMBOL);
1079	setimmutable (car (x));	1102	setimmutable (car (x));
1080		1103
1081	location = hash_fn (name, veclength (SCHEME_V->oblist));	1104	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)));	1105	vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1083	return x;	1106	return x;
1084	}	1107	}
1085		1108
1086	static INLINE pointer	1109	ecb_inline pointer
1087	oblist_find_by_name (SCHEME_P_ const char *name)	1110	oblist_find_by_name (SCHEME_P_ const char *name)
1088	{	1111	{
1089	int location;	1112	int location;
1090	pointer x;	1113	pointer x;
1091	char *s;	1114	char *s;
1092		1115
1093	location = hash_fn (name, veclength (SCHEME_V->oblist));	1116	location = hash_fn (name, veclength (SCHEME_V->oblist));
1094		1117
1095	for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))	1118	for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1096	{	1119	{
1097	s = symname (car (x));	1120	s = symname (car (x));
1098		1121
1099	/* case-insensitive, per R5RS section 2 */	1122	/* case-insensitive, per R5RS section 2 */
1100	if (stricmp (name, s) == 0)	1123	if (stricmp (name, s) == 0)
…		…
1110	int i;	1133	int i;
1111	pointer x;	1134	pointer x;
1112	pointer ob_list = NIL;	1135	pointer ob_list = NIL;
1113		1136
1114	for (i = 0; i < veclength (SCHEME_V->oblist); i++)	1137	for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1115	for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))	1138	for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1116	ob_list = cons (x, ob_list);	1139	ob_list = cons (x, ob_list);
1117		1140
1118	return ob_list;	1141	return ob_list;
1119	}	1142	}
1120		1143
…		…
1124	oblist_initial_value (SCHEME_P)	1147	oblist_initial_value (SCHEME_P)
1125	{	1148	{
1126	return NIL;	1149	return NIL;
1127	}	1150	}
1128		1151
1129	static INLINE pointer	1152	ecb_inline pointer
1130	oblist_find_by_name (SCHEME_P_ const char *name)	1153	oblist_find_by_name (SCHEME_P_ const char *name)
1131	{	1154	{
1132	pointer x;	1155	pointer x;
1133	char *s;	1156	char *s;
1134		1157
…		…
1193	mk_character (SCHEME_P_ int c)	1216	mk_character (SCHEME_P_ int c)
1194	{	1217	{
1195	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1218	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1196		1219
1197	set_typeflag (x, (T_CHARACTER | T_ATOM));	1220	set_typeflag (x, (T_CHARACTER | T_ATOM));
1198	ivalue_unchecked (x) = c & 0xff;	1221	set_ivalue (x, c & 0xff);
1199	set_num_integer (x);	1222
1200	return x;	1223	return x;
1201	}	1224	}
1202		1225
1203	/* get number atom (integer) */	1226	/* get number atom (integer) */
1204	INTERFACE pointer	1227	INTERFACE pointer
1205	mk_integer (SCHEME_P_ long num)	1228	mk_integer (SCHEME_P_ long n)
1206	{	1229	{
1207	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1230	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1208		1231
1209	set_typeflag (x, (T_NUMBER | T_ATOM));	1232	set_typeflag (x, (T_INTEGER | T_ATOM));
1210	ivalue_unchecked (x) = num;	1233	set_ivalue (x, n);
1211	set_num_integer (x);	1234
1212	return x;	1235	return x;
1213	}	1236	}
1214		1237
1215	INTERFACE pointer	1238	INTERFACE pointer
1216	mk_real (SCHEME_P_ RVALUE n)	1239	mk_real (SCHEME_P_ RVALUE n)
1217	{	1240	{
		1241	#if USE_REAL
1218	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1242	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1219		1243
1220	set_typeflag (x, (T_NUMBER | T_ATOM));	1244	set_typeflag (x, (T_REAL | T_ATOM));
1221	rvalue_unchecked (x) = n;	1245	set_rvalue (x, n);
1222	set_num_real (x);	1246
1223	return x;	1247	return x;
		1248	#else
		1249	return mk_integer (SCHEME_A_ n);
		1250	#endif
1224	}	1251	}
1225		1252
1226	static pointer	1253	static pointer
1227	mk_number (SCHEME_P_ const num n)	1254	mk_number (SCHEME_P_ const num n)
1228	{	1255	{
		1256	#if USE_REAL
1229	if (num_is_fixnum (n))	1257	return num_is_fixnum (n)
		1258	? mk_integer (SCHEME_A_ num_ivalue (n))
		1259	: mk_real (SCHEME_A_ num_rvalue (n));
		1260	#else
1230	return mk_integer (SCHEME_A_ num_get_ivalue (n));	1261	return mk_integer (SCHEME_A_ num_ivalue (n));
1231	else	1262	#endif
1232	return mk_real (SCHEME_A_ num_get_rvalue (n));
1233	}	1263	}
1234		1264
1235	/* allocate name to string area */	1265	/* allocate name to string area */
1236	static char *	1266	static char *
1237	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)	1267	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
…		…
1296	{	1326	{
1297	return get_vector_object (SCHEME_A_ len, NIL);	1327	return get_vector_object (SCHEME_A_ len, NIL);
1298	}	1328	}
1299		1329
1300	INTERFACE void	1330	INTERFACE void
1301	fill_vector (pointer vec, pointer obj)	1331	fill_vector (pointer vec, uint32_t start, pointer obj)
1302	{	1332	{
1303	int i;	1333	int i;
1304		1334
1305	for (i = 0; i < vec->object.vector.length; i++)	1335	for (i = start; i < veclength (vec); i++)
1306	vecvalue (vec)[i] = obj;	1336	vecvalue (vec)[i] = obj;
1307	}	1337	}
1308		1338
1309	INTERFACE pointer	1339	INTERFACE pointer
1310	vector_elem (pointer vec, uint32_t ielem)	1340	vector_get (pointer vec, uint32_t ielem)
1311	{	1341	{
1312	return vecvalue(vec)[ielem];	1342	return vecvalue(vec)[ielem];
1313	}	1343	}
1314		1344
1315	INTERFACE void	1345	INTERFACE void
1316	set_vector_elem (pointer vec, uint32_t ielem, pointer a)	1346	vector_set (pointer vec, uint32_t ielem, pointer a)
1317	{	1347	{
1318	vecvalue(vec)[ielem] = a;	1348	vecvalue(vec)[ielem] = a;
1319	}	1349	}
1320		1350
1321	/* get new symbol */	1351	/* get new symbol */
…		…
1413	}	1443	}
1414	else if ((c == 'e') || (c == 'E'))	1444	else if ((c == 'e') || (c == 'E'))
1415	{	1445	{
1416	if (!has_fp_exp)	1446	if (!has_fp_exp)
1417	{	1447	{
1418	has_dec_point = 1; /* decimal point illegal	1448	has_dec_point = 1; /* decimal point illegal from now on */
1419	from now on */
1420	p++;	1449	p++;
1421		1450
1422	if ((*p == '-') || (*p == '+') || isdigit (*p))	1451	if ((*p == '-') || (*p == '+') || isdigit (*p))
1423	continue;	1452	continue;
1424	}	1453	}
…		…
1512		1541
1513	if (ecb_expect_false (is_vector (p)))	1542	if (ecb_expect_false (is_vector (p)))
1514	{	1543	{
1515	int i;	1544	int i;
1516		1545
1517	for (i = 0; i < p->object.vector.length; i++)	1546	for (i = 0; i < veclength (p); i++)
1518	mark (vecvalue (p)[i]);	1547	mark (vecvalue (p)[i]);
1519	}	1548	}
1520		1549
1521	if (is_atom (p))	1550	if (is_atom (p))
1522	goto E6;	1551	goto E6;
…		…
1620	if (is_mark (p))	1649	if (is_mark (p))
1621	clrmark (p);	1650	clrmark (p);
1622	else	1651	else
1623	{	1652	{
1624	/* reclaim cell */	1653	/* reclaim cell */
1625	if (typeflag (p) != T_FREE)	1654	if (typeflag (p) != T_PAIR)
1626	{	1655	{
1627	finalize_cell (SCHEME_A_ p);	1656	finalize_cell (SCHEME_A_ p);
1628	set_typeflag (p, T_FREE);	1657	set_typeflag (p, T_PAIR);
1629	set_car (p, NIL);	1658	set_car (p, NIL);
1630	}	1659	}
1631		1660
1632	++SCHEME_V->fcells;	1661	++SCHEME_V->fcells;
1633	set_cdr (p, SCHEME_V->free_cell);	1662	set_cdr (p, SCHEME_V->free_cell);
…		…
1635	}	1664	}
1636	}	1665	}
1637	}	1666	}
1638		1667
1639	if (SCHEME_V->gc_verbose)	1668	if (SCHEME_V->gc_verbose)
		1669	{
1640	xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");	1670	xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");
		1671	}
1641	}	1672	}
1642		1673
1643	static void	1674	static void
1644	finalize_cell (SCHEME_P_ pointer a)	1675	finalize_cell (SCHEME_P_ pointer a)
1645	{	1676	{
…		…
2232	}	2263	}
2233	}	2264	}
2234	}	2265	}
2235		2266
2236	/* check c is in chars */	2267	/* check c is in chars */
2237	static INLINE int	2268	ecb_inline int
2238	is_one_of (char *s, int c)	2269	is_one_of (char *s, int c)
2239	{	2270	{
2240	if (c == EOF)	2271	if (c == EOF)
2241	return 1;	2272	return 1;
2242		2273
2243	return !!strchr (s, c);	2274	return !!strchr (s, c);
2244	}	2275	}
2245		2276
2246	/* skip white characters */	2277	/* skip white characters */
2247	static INLINE int	2278	ecb_inline int
2248	skipspace (SCHEME_P)	2279	skipspace (SCHEME_P)
2249	{	2280	{
2250	int c, curr_line = 0;	2281	int c, curr_line = 0;
2251		2282
2252	do	2283	do
…		…
2480	{	2511	{
2481	p = SCHEME_V->strbuff;	2512	p = SCHEME_V->strbuff;
2482		2513
2483	if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */	2514	if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2484	{	2515	{
2485	if (num_is_integer (l))	2516	if (is_integer (l))
2486	xnum (p, ivalue_unchecked (l));	2517	xnum (p, ivalue_unchecked (l));
2487	#if USE_REAL	2518	#if USE_REAL
2488	else	2519	else
2489	{	2520	{
2490	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));	2521	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
…		…
2745	return 0;	2776	return 0;
2746	}	2777	}
2747	else if (is_number (a))	2778	else if (is_number (a))
2748	{	2779	{
2749	if (is_number (b))	2780	if (is_number (b))
2750	if (num_is_integer (a) == num_is_integer (b))
2751	return num_cmp (nvalue (a), nvalue (b)) == 0;	2781	return num_cmp (nvalue (a), nvalue (b)) == 0;
2752		2782
2753	return 0;	2783	return 0;
2754	}	2784	}
2755	else if (is_character (a))	2785	else if (is_character (a))
2756	{	2786	{
…		…
2823		2853
2824	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2854	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2825	setenvironment (SCHEME_V->envir);	2855	setenvironment (SCHEME_V->envir);
2826	}	2856	}
2827		2857
2828	static INLINE void	2858	ecb_inline void
2829	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2859	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2830	{	2860	{
2831	pointer slot = immutable_cons (variable, value);	2861	pointer slot = immutable_cons (variable, value);
2832		2862
2833	if (is_vector (car (env)))	2863	if (is_vector (car (env)))
2834	{	2864	{
2835	int location = hash_fn (symname (variable), veclength (car (env)));	2865	int location = hash_fn (symname (variable), veclength (car (env)));
2836		2866
2837	set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));	2867	vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2838	}	2868	}
2839	else	2869	else
2840	set_car (env, immutable_cons (slot, car (env)));	2870	set_car (env, immutable_cons (slot, car (env)));
2841	}	2871	}
2842		2872
…		…
2849	for (x = env; x != NIL; x = cdr (x))	2879	for (x = env; x != NIL; x = cdr (x))
2850	{	2880	{
2851	if (is_vector (car (x)))	2881	if (is_vector (car (x)))
2852	{	2882	{
2853	location = hash_fn (symname (hdl), veclength (car (x)));	2883	location = hash_fn (symname (hdl), veclength (car (x)));
2854	y = vector_elem (car (x), location);	2884	y = vector_get (car (x), location);
2855	}	2885	}
2856	else	2886	else
2857	y = car (x);	2887	y = car (x);
2858		2888
2859	for (; y != NIL; y = cdr (y))	2889	for (; y != NIL; y = cdr (y))
…		…
2873	return NIL;	2903	return NIL;
2874	}	2904	}
2875		2905
2876	#else /* USE_ALIST_ENV */	2906	#else /* USE_ALIST_ENV */
2877		2907
2878	static INLINE void	2908	ecb_inline void
2879	new_frame_in_env (SCHEME_P_ pointer old_env)	2909	new_frame_in_env (SCHEME_P_ pointer old_env)
2880	{	2910	{
2881	SCHEME_V->envir = immutable_cons (NIL, old_env);	2911	SCHEME_V->envir = immutable_cons (NIL, old_env);
2882	setenvironment (SCHEME_V->envir);	2912	setenvironment (SCHEME_V->envir);
2883	}	2913	}
2884		2914
2885	static INLINE void	2915	ecb_inline void
2886	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2916	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2887	{	2917	{
2888	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2918	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2889	}	2919	}
2890		2920
…		…
2912	return NIL;	2942	return NIL;
2913	}	2943	}
2914		2944
2915	#endif /* USE_ALIST_ENV else */	2945	#endif /* USE_ALIST_ENV else */
2916		2946
2917	static INLINE void	2947	ecb_inline void
2918	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2948	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2919	{	2949	{
2920	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);	2950	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2921	}	2951	}
2922		2952
2923	static INLINE void	2953	ecb_inline void
2924	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2954	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2925	{	2955	{
2926	set_cdr (slot, value);	2956	set_cdr (slot, value);
2927	}	2957	}
2928		2958
2929	static INLINE pointer	2959	ecb_inline pointer
2930	slot_value_in_env (pointer slot)	2960	slot_value_in_env (pointer slot)
2931	{	2961	{
2932	return cdr (slot);	2962	return cdr (slot);
2933	}	2963	}
2934		2964
…		…
3062	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3092	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3063		3093
3064	return 0;	3094	return 0;
3065	}	3095	}
3066		3096
3067	static INLINE void	3097	ecb_inline void
3068	dump_stack_reset (SCHEME_P)	3098	dump_stack_reset (SCHEME_P)
3069	{	3099	{
3070	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */	3100	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3071	SCHEME_V->dump = (pointer)+0;	3101	SCHEME_V->dump = (pointer)+0;
3072	}	3102	}
3073		3103
3074	static INLINE void	3104	ecb_inline void
3075	dump_stack_initialize (SCHEME_P)	3105	dump_stack_initialize (SCHEME_P)
3076	{	3106	{
3077	SCHEME_V->dump_size = 0;	3107	SCHEME_V->dump_size = 0;
3078	SCHEME_V->dump_base = 0;	3108	SCHEME_V->dump_base = 0;
3079	dump_stack_reset (SCHEME_A);	3109	dump_stack_reset (SCHEME_A);
…		…
3132	int i = 0;	3162	int i = 0;
3133	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3163	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3134		3164
3135	while (cont != NIL)	3165	while (cont != NIL)
3136	{	3166	{
3137	frame->op = ivalue (car (cont)); cont = cdr (cont);	3167	frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont);
3138	frame->args = car (cont) ; cont = cdr (cont);	3168	frame->args = car (cont) ; cont = cdr (cont);
3139	frame->envir = car (cont) ; cont = cdr (cont);	3169	frame->envir = car (cont) ; cont = cdr (cont);
3140	frame->code = car (cont) ; cont = cdr (cont);	3170	frame->code = car (cont) ; cont = cdr (cont);
3141		3171
3142	++frame;	3172	++frame;
3143	++i;	3173	++i;
3144	}	3174	}
3145		3175
3146	SCHEME_V->dump = (pointer)(uintptr_t)i;	3176	SCHEME_V->dump = (pointer)(uintptr_t)i;
3147	}	3177	}
3148		3178
3149	#else	3179	#else
3150		3180
3151	static INLINE void	3181	ecb_inline void
3152	dump_stack_reset (SCHEME_P)	3182	dump_stack_reset (SCHEME_P)
3153	{	3183	{
3154	SCHEME_V->dump = NIL;	3184	SCHEME_V->dump = NIL;
3155	}	3185	}
3156		3186
3157	static INLINE void	3187	ecb_inline void
3158	dump_stack_initialize (SCHEME_P)	3188	dump_stack_initialize (SCHEME_P)
3159	{	3189	{
3160	dump_stack_reset (SCHEME_A);	3190	dump_stack_reset (SCHEME_A);
3161	}	3191	}
3162		3192
…		…
3174	SCHEME_V->value = a;	3204	SCHEME_V->value = a;
3175		3205
3176	if (dump == NIL)	3206	if (dump == NIL)
3177	return -1;	3207	return -1;
3178		3208
3179	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);	3209	SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump);
3180	SCHEME_V->args = car (dump) ; dump = cdr (dump);	3210	SCHEME_V->args = car (dump) ; dump = cdr (dump);
3181	SCHEME_V->envir = car (dump) ; dump = cdr (dump);	3211	SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3182	SCHEME_V->code = car (dump) ; dump = cdr (dump);	3212	SCHEME_V->code = car (dump) ; dump = cdr (dump);
3183		3213
3184	SCHEME_V->dump = dump;	3214	SCHEME_V->dump = dump;
3185		3215
3186	return 0;	3216	return 0;
3187	}	3217	}
…		…
3393		3423
3394	case OP_TRACING:	3424	case OP_TRACING:
3395	{	3425	{
3396	int tr = SCHEME_V->tracing;	3426	int tr = SCHEME_V->tracing;
3397		3427
3398	SCHEME_V->tracing = ivalue (car (args));	3428	SCHEME_V->tracing = ivalue_unchecked (car (args));
3399	s_return (mk_integer (SCHEME_A_ tr));	3429	s_return (mk_integer (SCHEME_A_ tr));
3400	}	3430	}
3401		3431
3402	#endif	3432	#endif
3403		3433
…		…
3912	SCHEME_V->code = car (args);	3942	SCHEME_V->code = car (args);
3913	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);	3943	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3914	s_goto (OP_APPLY);	3944	s_goto (OP_APPLY);
3915	}	3945	}
3916		3946
3917	abort ();	3947	if (USE_ERROR_CHECKING) abort ();
3918	}	3948	}
3919		3949
3920	static int	3950	static int
3921	opexe_1 (SCHEME_P_ enum scheme_opcodes op)	3951	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3922	{	3952	{
3923	pointer args = SCHEME_V->args;	3953	pointer args = SCHEME_V->args;
3924	pointer x = car (args);	3954	pointer x = car (args);
3925	num v;	3955	num v;
3926		3956
3927	#if USE_MATH
3928	RVALUE dd;
3929	#endif
3930
3931	switch (op)	3957	switch (op)
3932	{	3958	{
3933	#if USE_MATH	3959	#if USE_MATH
3934	case OP_INEX2EX: /* inexact->exact */	3960	case OP_INEX2EX: /* inexact->exact */
		3961	{
3935	if (num_is_integer (x))	3962	if (is_integer (x))
3936	s_return (x);	3963	s_return (x);
3937	else if (modf (rvalue_unchecked (x), &dd) == 0)	3964
		3965	RVALUE r = rvalue_unchecked (x);
		3966
		3967	if (r == (RVALUE)(IVALUE)r)
3938	s_return (mk_integer (SCHEME_A_ ivalue (x)));	3968	s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x)));
3939	else	3969	else
3940	Error_1 ("inexact->exact: not integral:", x);	3970	Error_1 ("inexact->exact: not integral:", x);
		3971	}
3941		3972
3942	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));	3973	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
3943	case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))));	3974	case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))));
3944	case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));	3975	case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
3945	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));	3976	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
…		…
3963	{	3994	{
3964	RVALUE result;	3995	RVALUE result;
3965	int real_result = 1;	3996	int real_result = 1;
3966	pointer y = cadr (args);	3997	pointer y = cadr (args);
3967		3998
3968	if (num_is_integer (x) && num_is_integer (y))	3999	if (is_integer (x) && is_integer (y))
3969	real_result = 0;	4000	real_result = 0;
3970		4001
3971	/* This 'if' is an R5RS compatibility fix. */	4002	/* This 'if' is an R5RS compatibility fix. */
3972	/* NOTE: Remove this 'if' fix for R6RS. */	4003	/* NOTE: Remove this 'if' fix for R6RS. */
3973	if (rvalue (x) == 0 && rvalue (y) < 0)	4004	if (rvalue (x) == 0 && rvalue (y) < 0)
…		…
3979	/* If the test fails, result is too big for integer. */	4010	/* If the test fails, result is too big for integer. */
3980	if (!real_result)	4011	if (!real_result)
3981	{	4012	{
3982	long result_as_long = result;	4013	long result_as_long = result;
3983		4014
3984	if (result != (RVALUE) result_as_long)	4015	if (result != result_as_long)
3985	real_result = 1;	4016	real_result = 1;
3986	}	4017	}
3987		4018
3988	if (real_result)	4019	if (real_result)
3989	s_return (mk_real (SCHEME_A_ result));	4020	s_return (mk_real (SCHEME_A_ result));
…		…
3994	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));	4025	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
3995	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));	4026	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
3996		4027
3997	case OP_TRUNCATE:	4028	case OP_TRUNCATE:
3998	{	4029	{
3999	RVALUE rvalue_of_x;	4030	RVALUE n = rvalue (x);
4000
4001	rvalue_of_x = rvalue (x);
4002
4003	if (rvalue_of_x > 0)
4004	s_return (mk_real (SCHEME_A_ floor (rvalue_of_x)));	4031	s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4005	else
4006	s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x)));
4007	}	4032	}
4008		4033
4009	case OP_ROUND:	4034	case OP_ROUND:
4010	if (num_is_integer (x))	4035	if (is_integer (x))
4011	s_return (x);	4036	s_return (x);
4012		4037
4013	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));	4038	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4014	#endif	4039	#endif
4015		4040
4016	case OP_ADD: /* + */	4041	case OP_ADD: /* + */
4017	v = num_zero;	4042	v = num_zero;
4018		4043
4019	for (x = args; x != NIL; x = cdr (x))	4044	for (x = args; x != NIL; x = cdr (x))
4020	v = num_op ('+', v, nvalue (car (x)));	4045	v = num_op (NUM_ADD, v, nvalue (car (x)));
4021		4046
4022	s_return (mk_number (SCHEME_A_ v));	4047	s_return (mk_number (SCHEME_A_ v));
4023		4048
4024	case OP_MUL: /* * */	4049	case OP_MUL: /* * */
4025	v = num_one;	4050	v = num_one;
4026		4051
4027	for (x = args; x != NIL; x = cdr (x))	4052	for (x = args; x != NIL; x = cdr (x))
4028	v = num_op ('*', v, nvalue (car (x)));	4053	v = num_op (NUM_MUL, v, nvalue (car (x)));
4029		4054
4030	s_return (mk_number (SCHEME_A_ v));	4055	s_return (mk_number (SCHEME_A_ v));
4031		4056
4032	case OP_SUB: /* - */	4057	case OP_SUB: /* - */
4033	if (cdr (args) == NIL)	4058	if (cdr (args) == NIL)
…		…
4040	x = cdr (args);	4065	x = cdr (args);
4041	v = nvalue (car (args));	4066	v = nvalue (car (args));
4042	}	4067	}
4043		4068
4044	for (; x != NIL; x = cdr (x))	4069	for (; x != NIL; x = cdr (x))
4045	v = num_op ('-', v, nvalue (car (x)));	4070	v = num_op (NUM_SUB, v, nvalue (car (x)));
4046		4071
4047	s_return (mk_number (SCHEME_A_ v));	4072	s_return (mk_number (SCHEME_A_ v));
4048		4073
4049	case OP_DIV: /* / */	4074	case OP_DIV: /* / */
4050	if (cdr (args) == NIL)	4075	if (cdr (args) == NIL)
…		…
4057	x = cdr (args);	4082	x = cdr (args);
4058	v = nvalue (car (args));	4083	v = nvalue (car (args));
4059	}	4084	}
4060		4085
4061	for (; x != NIL; x = cdr (x))	4086	for (; x != NIL; x = cdr (x))
4062	{
4063	if (!is_zero_rvalue (rvalue (car (x))))	4087	if (!is_zero_rvalue (rvalue (car (x))))
4064	v = num_div (v, nvalue (car (x)));	4088	v = num_div (v, nvalue (car (x)));
4065	else	4089	else
4066	Error_0 ("/: division by zero");	4090	Error_0 ("/: division by zero");
4067	}
4068		4091
4069	s_return (mk_number (SCHEME_A_ v));	4092	s_return (mk_number (SCHEME_A_ v));
4070		4093
4071	case OP_INTDIV: /* quotient */	4094	case OP_INTDIV: /* quotient */
4072	if (cdr (args) == NIL)	4095	if (cdr (args) == NIL)
…		…
4081	}	4104	}
4082		4105
4083	for (; x != NIL; x = cdr (x))	4106	for (; x != NIL; x = cdr (x))
4084	{	4107	{
4085	if (ivalue (car (x)) != 0)	4108	if (ivalue (car (x)) != 0)
4086	v = num_op ('/', v, nvalue (car (x)));	4109	v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4087	else	4110	else
4088	Error_0 ("quotient: division by zero");	4111	Error_0 ("quotient: division by zero");
4089	}	4112	}
4090		4113
4091	s_return (mk_number (SCHEME_A_ v));	4114	s_return (mk_number (SCHEME_A_ v));
…		…
4137	}	4160	}
4138	else	4161	else
4139	Error_0 ("set-cdr!: unable to alter immutable pair");	4162	Error_0 ("set-cdr!: unable to alter immutable pair");
4140		4163
4141	case OP_CHAR2INT: /* char->integer */	4164	case OP_CHAR2INT: /* char->integer */
4142	s_return (mk_integer (SCHEME_A_ ivalue (x)));	4165	s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x)));
4143		4166
4144	case OP_INT2CHAR: /* integer->char */	4167	case OP_INT2CHAR: /* integer->char */
4145	s_return (mk_character (SCHEME_A_ ivalue (x)));	4168	s_return (mk_character (SCHEME_A_ ivalue_unchecked (x)));
4146		4169
4147	case OP_CHARUPCASE:	4170	case OP_CHARUPCASE:
4148	{	4171	{
4149	unsigned char c = ivalue (x);	4172	unsigned char c = ivalue_unchecked (x);
4150	c = toupper (c);	4173	c = toupper (c);
4151	s_return (mk_character (SCHEME_A_ c));	4174	s_return (mk_character (SCHEME_A_ c));
4152	}	4175	}
4153		4176
4154	case OP_CHARDNCASE:	4177	case OP_CHARDNCASE:
4155	{	4178	{
4156	unsigned char c = ivalue (x);	4179	unsigned char c = ivalue_unchecked (x);
4157	c = tolower (c);	4180	c = tolower (c);
4158	s_return (mk_character (SCHEME_A_ c));	4181	s_return (mk_character (SCHEME_A_ c));
4159	}	4182	}
4160		4183
4161	case OP_STR2SYM: /* string->symbol */	4184	case OP_STR2SYM: /* string->symbol */
…		…
4238	Error_1 ("atom->string: not an atom:", x);	4261	Error_1 ("atom->string: not an atom:", x);
4239	}	4262	}
4240		4263
4241	case OP_MKSTRING: /* make-string */	4264	case OP_MKSTRING: /* make-string */
4242	{	4265	{
4243	int fill = ' ';	4266	int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' ';
4244	int len;
4245
4246	len = ivalue (x);	4267	int len = ivalue_unchecked (x);
4247
4248	if (cdr (args) != NIL)
4249	fill = charvalue (cadr (args));
4250		4268
4251	s_return (mk_empty_string (SCHEME_A_ len, fill));	4269	s_return (mk_empty_string (SCHEME_A_ len, fill));
4252	}	4270	}
4253		4271
4254	case OP_STRLEN: /* string-length */	4272	case OP_STRLEN: /* string-length */
4255	s_return (mk_integer (SCHEME_A_ strlength (x)));	4273	s_return (mk_integer (SCHEME_A_ strlength (x)));
4256		4274
4257	case OP_STRREF: /* string-ref */	4275	case OP_STRREF: /* string-ref */
4258	{	4276	{
4259	char *str;
4260	int index;
4261
4262	str = strvalue (x);	4277	char *str = strvalue (x);
4263
4264	index = ivalue (cadr (args));	4278	int index = ivalue_unchecked (cadr (args));
4265		4279
4266	if (index >= strlength (x))	4280	if (index >= strlength (x))
4267	Error_1 ("string-ref: out of bounds:", cadr (args));	4281	Error_1 ("string-ref: out of bounds:", cadr (args));
4268		4282
4269	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));	4283	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4270	}	4284	}
4271		4285
4272	case OP_STRSET: /* string-set! */	4286	case OP_STRSET: /* string-set! */
4273	{	4287	{
4274	char *str;	4288	char *str = strvalue (x);
4275	int index;	4289	int index = ivalue_unchecked (cadr (args));
4276	int c;	4290	int c;
4277		4291
4278	if (is_immutable (x))	4292	if (is_immutable (x))
4279	Error_1 ("string-set!: unable to alter immutable string:", x);	4293	Error_1 ("string-set!: unable to alter immutable string:", x);
4280
4281	str = strvalue (x);
4282
4283	index = ivalue (cadr (args));
4284		4294
4285	if (index >= strlength (x))	4295	if (index >= strlength (x))
4286	Error_1 ("string-set!: out of bounds:", cadr (args));	4296	Error_1 ("string-set!: out of bounds:", cadr (args));
4287		4297
4288	c = charvalue (caddr (args));	4298	c = charvalue (caddr (args));
…		…
4311	s_return (newstr);	4321	s_return (newstr);
4312	}	4322	}
4313		4323
4314	case OP_SUBSTR: /* substring */	4324	case OP_SUBSTR: /* substring */
4315	{	4325	{
4316	char *str;	4326	char *str = strvalue (x);
4317	int index0;	4327	int index0 = ivalue_unchecked (cadr (args));
4318	int index1;	4328	int index1;
4319	int len;	4329	int len;
4320		4330
4321	str = strvalue (x);
4322
4323	index0 = ivalue (cadr (args));
4324
4325	if (index0 > strlength (x))	4331	if (index0 > strlength (x))
4326	Error_1 ("substring: start out of bounds:", cadr (args));	4332	Error_1 ("substring: start out of bounds:", cadr (args));
4327		4333
4328	if (cddr (args) != NIL)	4334	if (cddr (args) != NIL)
4329	{	4335	{
4330	index1 = ivalue (caddr (args));	4336	index1 = ivalue_unchecked (caddr (args));
4331		4337
4332	if (index1 > strlength (x) || index1 < index0)	4338	if (index1 > strlength (x) || index1 < index0)
4333	Error_1 ("substring: end out of bounds:", caddr (args));	4339	Error_1 ("substring: end out of bounds:", caddr (args));
4334	}	4340	}
4335	else	4341	else
…		…
4358	if (SCHEME_V->no_memory)	4364	if (SCHEME_V->no_memory)
4359	s_return (S_SINK);	4365	s_return (S_SINK);
4360	#endif	4366	#endif
4361		4367
4362	for (x = args, i = 0; is_pair (x); x = cdr (x), i++)	4368	for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4363	set_vector_elem (vec, i, car (x));	4369	vector_set (vec, i, car (x));
4364		4370
4365	s_return (vec);	4371	s_return (vec);
4366	}	4372	}
4367		4373
4368	case OP_MKVECTOR: /* make-vector */	4374	case OP_MKVECTOR: /* make-vector */
4369	{	4375	{
4370	pointer fill = NIL;	4376	pointer fill = NIL;
4371	int len;
4372	pointer vec;	4377	pointer vec;
4373
4374	len = ivalue (x);	4378	int len = ivalue_unchecked (x);
4375		4379
4376	if (cdr (args) != NIL)	4380	if (cdr (args) != NIL)
4377	fill = cadr (args);	4381	fill = cadr (args);
4378		4382
4379	vec = mk_vector (SCHEME_A_ len);	4383	vec = mk_vector (SCHEME_A_ len);
…		…
4382	if (SCHEME_V->no_memory)	4386	if (SCHEME_V->no_memory)
4383	s_return (S_SINK);	4387	s_return (S_SINK);
4384	#endif	4388	#endif
4385		4389
4386	if (fill != NIL)	4390	if (fill != NIL)
4387	fill_vector (vec, fill);	4391	fill_vector (vec, 0, fill);
4388		4392
4389	s_return (vec);	4393	s_return (vec);
4390	}	4394	}
4391		4395
4392	case OP_VECLEN: /* vector-length */	4396	case OP_VECLEN: /* vector-length */
4393	s_return (mk_integer (SCHEME_A_ veclength (x)));	4397	s_return (mk_integer (SCHEME_A_ veclength (x)));
4394		4398
4395	case OP_VECREF: /* vector-ref */	4399	case OP_VECREF: /* vector-ref */
4396	{	4400	{
4397	int index;
4398
4399	index = ivalue (cadr (args));	4401	int index = ivalue_unchecked (cadr (args));
4400		4402
4401	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)	4403	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4402	Error_1 ("vector-ref: out of bounds:", cadr (args));	4404	Error_1 ("vector-ref: out of bounds:", cadr (args));
4403		4405
4404	s_return (vector_elem (x, index));	4406	s_return (vector_get (x, index));
4405	}	4407	}
4406		4408
4407	case OP_VECSET: /* vector-set! */	4409	case OP_VECSET: /* vector-set! */
4408	{	4410	{
4409	int index;	4411	int index = ivalue_unchecked (cadr (args));
4410		4412
4411	if (is_immutable (x))	4413	if (is_immutable (x))
4412	Error_1 ("vector-set!: unable to alter immutable vector:", x);	4414	Error_1 ("vector-set!: unable to alter immutable vector:", x);
4413		4415
4414	index = ivalue (cadr (args));
4415
4416	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)	4416	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4417	Error_1 ("vector-set!: out of bounds:", cadr (args));	4417	Error_1 ("vector-set!: out of bounds:", cadr (args));
4418		4418
4419	set_vector_elem (x, index, caddr (args));	4419	vector_set (x, index, caddr (args));
4420	s_return (x);	4420	s_return (x);
4421	}	4421	}
4422	}	4422	}
4423		4423
4424	abort ();	4424	if (USE_ERROR_CHECKING) abort ();
4425	}
4426
4427	INTERFACE int
4428	is_list (SCHEME_P_ pointer a)
4429	{
4430	return list_length (SCHEME_A_ a) >= 0;
4431	}
4432
4433	/* Result is:
4434	proper list: length
4435	circular list: -1
4436	not even a pair: -2
4437	dotted list: -2 minus length before dot
4438	*/
4439	INTERFACE int
4440	list_length (SCHEME_P_ pointer a)
4441	{
4442	int i = 0;
4443	pointer slow, fast;
4444
4445	slow = fast = a;
4446
4447	while (1)
4448	{
4449	if (fast == NIL)
4450	return i;
4451
4452	if (!is_pair (fast))
4453	return -2 - i;
4454
4455	fast = cdr (fast);
4456	++i;
4457
4458	if (fast == NIL)
4459	return i;
4460
4461	if (!is_pair (fast))
4462	return -2 - i;
4463
4464	++i;
4465	fast = cdr (fast);
4466
4467	/* Safe because we would have already returned if `fast'
4468	encountered a non-pair. */
4469	slow = cdr (slow);
4470
4471	if (fast == slow)
4472	{
4473	/* the fast pointer has looped back around and caught up
4474	with the slow pointer, hence the structure is circular,
4475	not of finite length, and therefore not a list */
4476	return -1;
4477	}
4478	}
4479	}	4425	}
4480		4426
4481	static int	4427	static int
4482	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	4428	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4483	{	4429	{
…		…
4529	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;	4475	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4530	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */	4476	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4531	case OP_CHARP: /* char? */ r = is_character (a) ; break;	4477	case OP_CHARP: /* char? */ r = is_character (a) ; break;
4532		4478
4533	#if USE_CHAR_CLASSIFIERS	4479	#if USE_CHAR_CLASSIFIERS
4534	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue (a)); break;	4480	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4535	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue (a)); break;	4481	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4536	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue (a)); break;	4482	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
4537	case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue (a)); break;	4483	case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break;
4538	case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue (a)); break;	4484	case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break;
4539	#endif	4485	#endif
4540		4486
4541	#if USE_PORTS	4487	#if USE_PORTS
4542	case OP_PORTP: /* port? */ r = is_port (a) ; break;	4488	case OP_PORTP: /* port? */ r = is_port (a) ; break;
4543	case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;	4489	case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
…		…
4744		4690
4745	case OP_NEWSEGMENT: /* new-segment */	4691	case OP_NEWSEGMENT: /* new-segment */
4746	if (!is_pair (args) || !is_number (a))	4692	if (!is_pair (args) || !is_number (a))
4747	Error_0 ("new-segment: argument must be a number");	4693	Error_0 ("new-segment: argument must be a number");
4748		4694
4749	alloc_cellseg (SCHEME_A_ (int)ivalue (a));	4695	alloc_cellseg (SCHEME_A_ ivalue (a));
4750		4696
4751	s_return (S_T);	4697	s_return (S_T);
4752		4698
4753	case OP_OBLIST: /* oblist */	4699	case OP_OBLIST: /* oblist */
4754	s_return (oblist_all_symbols (SCHEME_A));	4700	s_return (oblist_all_symbols (SCHEME_A));
…		…
4783	break;	4729	break;
4784	}	4730	}
4785		4731
4786	p = port_from_filename (SCHEME_A_ strvalue (a), prop);	4732	p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4787		4733
4788	if (p == NIL)	4734	s_return (p == NIL ? S_F : p);
4789	s_return (S_F);
4790
4791	s_return (p);
4792	}	4735	}
4793		4736
4794	# if USE_STRING_PORTS	4737	# if USE_STRING_PORTS
4795		4738
4796	case OP_OPEN_INSTRING: /* open-input-string */	4739	case OP_OPEN_INSTRING: /* open-input-string */
…		…
4811	}	4754	}
4812		4755
4813	p = port_from_string (SCHEME_A_ strvalue (a),	4756	p = port_from_string (SCHEME_A_ strvalue (a),
4814	strvalue (a) + strlength (a), prop);	4757	strvalue (a) + strlength (a), prop);
4815		4758
4816	if (p == NIL)	4759	s_return (p == NIL ? S_F : p);
4817	s_return (S_F);
4818
4819	s_return (p);
4820	}	4760	}
4821		4761
4822	case OP_OPEN_OUTSTRING: /* open-output-string */	4762	case OP_OPEN_OUTSTRING: /* open-output-string */
4823	{	4763	{
4824	pointer p;	4764	pointer p;
4825		4765
4826	if (a == NIL)	4766	if (a == NIL)
4827	{
4828	p = port_from_scratch (SCHEME_A);	4767	p = port_from_scratch (SCHEME_A);
4829
4830	if (p == NIL)
4831	s_return (S_F);
4832	}
4833	else	4768	else
4834	{
4835	p = port_from_string (SCHEME_A_ strvalue (a),	4769	p = port_from_string (SCHEME_A_ strvalue (a),
4836	strvalue (a) + strlength (a), port_output);	4770	strvalue (a) + strlength (a), port_output);
4837		4771
4838	if (p == NIL)	4772	s_return (p == NIL ? S_F : p);
4839	s_return (S_F);
4840	}
4841
4842	s_return (p);
4843	}	4773	}
4844		4774
4845	case OP_GET_OUTSTRING: /* get-output-string */	4775	case OP_GET_OUTSTRING: /* get-output-string */
4846	{	4776	{
4847	port *p;	4777	port *p;
…		…
4886	case OP_CURR_ENV: /* current-environment */	4816	case OP_CURR_ENV: /* current-environment */
4887	s_return (SCHEME_V->envir);	4817	s_return (SCHEME_V->envir);
4888		4818
4889	}	4819	}
4890		4820
4891	abort ();	4821	if (USE_ERROR_CHECKING) abort ();
4892	}	4822	}
4893		4823
4894	static int	4824	static int
4895	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4825	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4896	{	4826	{
…		…
5215	putstr (SCHEME_A_ ")");	5145	putstr (SCHEME_A_ ")");
5216	s_return (S_T);	5146	s_return (S_T);
5217	}	5147	}
5218	else	5148	else
5219	{	5149	{
5220	pointer elem = vector_elem (vec, i);	5150	pointer elem = vector_get (vec, i);
5221		5151
5222	ivalue_unchecked (cdr (args)) = i + 1;	5152	ivalue_unchecked (cdr (args)) = i + 1;
5223	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);	5153	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5224	SCHEME_V->args = elem;	5154	SCHEME_V->args = elem;
5225		5155
…		…
5229	s_goto (OP_P0LIST);	5159	s_goto (OP_P0LIST);
5230	}	5160	}
5231	}	5161	}
5232	}	5162	}
5233		5163
5234	abort ();	5164	if (USE_ERROR_CHECKING) abort ();
5235	}	5165	}
5236		5166
5237	static int	5167	static int
5238	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5168	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5239	{	5169	{
…		…
5292		5222
5293	case OP_MACROP: /* macro? */	5223	case OP_MACROP: /* macro? */
5294	s_retbool (is_macro (a));	5224	s_retbool (is_macro (a));
5295	}	5225	}
5296		5226
5297	abort ();	5227	if (USE_ERROR_CHECKING) abort ();
5298	}	5228	}
5299		5229
5300	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */	5230	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5301	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);	5231	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5302		5232
5303	typedef int (*test_predicate)(pointer);	5233	typedef int (*test_predicate)(pointer);
5304	static int	5234	static int
5305	is_any (pointer p)	5235	tst_any (pointer p)
5306	{	5236	{
5307	return 1;	5237	return 1;
5308	}	5238	}
5309		5239
5310	static int	5240	static int
5311	is_nonneg (pointer p)	5241	tst_inonneg (pointer p)
5312	{	5242	{
5313	return ivalue (p) >= 0 && is_integer (p);	5243	return is_integer (p) && ivalue_unchecked (p) >= 0;
5314	}	5244	}
5315		5245
5316	static int	5246	static int
5317	tst_is_list (pointer p)	5247	tst_is_list (SCHEME_P_ pointer p)
5318	{	5248	{
5319	return p == NIL || is_pair (p);	5249	return p == NIL || is_pair (p);
5320	}	5250	}
5321		5251
5322	/* Correspond carefully with following defines! */	5252	/* Correspond carefully with following defines! */
5323	static struct	5253	static struct
5324	{	5254	{
5325	test_predicate fct;	5255	test_predicate fct;
5326	const char *kind;	5256	const char *kind;
5327	} tests[] =	5257	} tests[] = {
5328	{
5329	{ is_any, 0 },	5258	{ tst_any , 0 },
5330	{ is_string, "string" },	5259	{ is_string , "string" },
5331	{ is_symbol, "symbol" },	5260	{ is_symbol , "symbol" },
5332	{ is_port, "port" },	5261	{ is_port , "port" },
5333	{ is_inport, "input port" },	5262	{ is_inport , "input port" },
5334	{ is_outport, "output port" },	5263	{ is_outport , "output port" },
5335	{ is_environment, "environment" },	5264	{ is_environment, "environment" },
5336	{ is_pair, "pair" },	5265	{ is_pair , "pair" },
5337	{ tst_is_list, "pair or '()" },	5266	{ 0 , "pair or '()" },
5338	{ is_character, "character" },	5267	{ is_character , "character" },
5339	{ is_vector, "vector" },	5268	{ is_vector , "vector" },
5340	{ is_number, "number" },	5269	{ is_number , "number" },
5341	{ is_integer, "integer" },	5270	{ is_integer , "integer" },
5342	{ is_nonneg, "non-negative integer" }	5271	{ tst_inonneg , "non-negative integer" }
5343	};	5272	};
5344		5273
5345	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */	5274	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5346	#define TST_ANY "\001"	5275	#define TST_ANY "\001"
5347	#define TST_STRING "\002"	5276	#define TST_STRING "\002"
…		…
5388	typedef struct	5317	typedef struct
5389	{	5318	{
5390	uint8_t func;	5319	uint8_t func;
5391	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */	5320	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
5392	uint8_t builtin;	5321	uint8_t builtin;
		5322	#if USE_ERROR_CHECKING
5393	uint8_t min_arity;	5323	uint8_t min_arity;
5394	uint8_t max_arity;	5324	uint8_t max_arity;
5395	char arg_tests_encoding[3];	5325	char arg_tests_encoding[3];
		5326	#endif
5396	} op_code_info;	5327	} op_code_info;
5397		5328
5398	static const op_code_info dispatch_table[] = {	5329	static const op_code_info dispatch_table[] = {
		5330	#if USE_ERROR_CHECKING
5399	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },	5331	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
		5332	#else
		5333	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 },
		5334	#endif
5400	#include "opdefines.h"	5335	#include "opdefines.h"
5401	#undef OP_DEF	5336	#undef OP_DEF
5402	{0}	5337	{0}
5403	};	5338	};
5404		5339
5405	/* kernel of this interpreter */	5340	/* kernel of this interpreter */
5406	static void	5341	static void ecb_hot
5407	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5342	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5408	{	5343	{
5409	SCHEME_V->op = op;	5344	SCHEME_V->op = op;
5410		5345
5411	for (;;)	5346	for (;;)
…		…
5446	{	5381	{
5447	pointer arg = car (arglist);	5382	pointer arg = car (arglist);
5448		5383
5449	j = t[0];	5384	j = t[0];
5450		5385
		5386	/*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */
		5387	if (j == TST_LIST[0])
		5388	{
		5389	if (!tst_is_list (SCHEME_A_ arg))
		5390	break;
		5391	}
		5392	else
		5393	{
5451	if (!tests[j - 1].fct (arg))	5394	if (!tests[j - 1].fct (arg))
5452	break;	5395	break;
		5396	}
5453		5397
5454	if (t[1]) /* last test is replicated as necessary */	5398	if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */
5455	t++;	5399	t++;
5456		5400
5457	arglist = cdr (arglist);	5401	arglist = cdr (arglist);
5458	i++;	5402	i++;
5459	}	5403	}
…		…
5514	mk_proc (SCHEME_P_ enum scheme_opcodes op)	5458	mk_proc (SCHEME_P_ enum scheme_opcodes op)
5515	{	5459	{
5516	pointer y = get_cell (SCHEME_A_ NIL, NIL);	5460	pointer y = get_cell (SCHEME_A_ NIL, NIL);
5517	set_typeflag (y, (T_PROC | T_ATOM));	5461	set_typeflag (y, (T_PROC | T_ATOM));
5518	ivalue_unchecked (y) = op;	5462	ivalue_unchecked (y) = op;
5519	set_num_integer (y);
5520	return y;	5463	return y;
5521	}	5464	}
5522		5465
5523	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */	5466	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5524	static int	5467	static int
…		…
5589	return OP_C0STREAM; /* cons-stream */	5532	return OP_C0STREAM; /* cons-stream */
5590	}	5533	}
5591	}	5534	}
5592		5535
5593	#if USE_MULTIPLICITY	5536	#if USE_MULTIPLICITY
5594	scheme *	5537	ecb_cold scheme *
5595	scheme_init_new ()	5538	scheme_init_new ()
5596	{	5539	{
5597	scheme *sc = malloc (sizeof (scheme));	5540	scheme *sc = malloc (sizeof (scheme));
5598		5541
5599	if (!scheme_init (SCHEME_A))	5542	if (!scheme_init (SCHEME_A))
…		…
5604	else	5547	else
5605	return sc;	5548	return sc;
5606	}	5549	}
5607	#endif	5550	#endif
5608		5551
5609	int	5552	ecb_cold int
5610	scheme_init (SCHEME_P)	5553	scheme_init (SCHEME_P)
5611	{	5554	{
5612	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	5555	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5613	pointer x;	5556	pointer x;
5614		5557
…		…
5739	scheme_set_external_data (SCHEME_P_ void *p)	5682	scheme_set_external_data (SCHEME_P_ void *p)
5740	{	5683	{
5741	SCHEME_V->ext_data = p;	5684	SCHEME_V->ext_data = p;
5742	}	5685	}
5743		5686
5744	void	5687	ecb_cold void
5745	scheme_deinit (SCHEME_P)	5688	scheme_deinit (SCHEME_P)
5746	{	5689	{
5747	int i;	5690	int i;
5748		5691
5749	#if SHOW_ERROR_LINE	5692	#if SHOW_ERROR_LINE

Diff Legend

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