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.32 by root, Sat Nov 28 10:56:45 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
…		…
1146		1169
1147	/* returns the new symbol */	1170	/* returns the new symbol */
1148	static pointer	1171	static pointer
1149	oblist_add_by_name (SCHEME_P_ const char *name)	1172	oblist_add_by_name (SCHEME_P_ const char *name)
1150	{	1173	{
1151	pointer x;	1174	pointer x = mk_string (SCHEME_A_ name);
1152
1153	x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1154	set_typeflag (x, T_SYMBOL);	1175	set_typeflag (x, T_SYMBOL);
1155	setimmutable (car (x));	1176	setimmutable (x);
1156	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);	1177	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1157	return x;	1178	return x;
1158	}	1179	}
1159		1180
1160	static pointer	1181	static pointer
…		…
1193	mk_character (SCHEME_P_ int c)	1214	mk_character (SCHEME_P_ int c)
1194	{	1215	{
1195	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1216	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1196		1217
1197	set_typeflag (x, (T_CHARACTER | T_ATOM));	1218	set_typeflag (x, (T_CHARACTER | T_ATOM));
1198	ivalue_unchecked (x) = c & 0xff;	1219	set_ivalue (x, c & 0xff);
1199	set_num_integer (x);	1220
1200	return x;	1221	return x;
1201	}	1222	}
1202		1223
1203	/* get number atom (integer) */	1224	/* get number atom (integer) */
1204	INTERFACE pointer	1225	INTERFACE pointer
1205	mk_integer (SCHEME_P_ long num)	1226	mk_integer (SCHEME_P_ long n)
1206	{	1227	{
1207	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1228	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1208		1229
1209	set_typeflag (x, (T_NUMBER | T_ATOM));	1230	set_typeflag (x, (T_INTEGER | T_ATOM));
1210	ivalue_unchecked (x) = num;	1231	set_ivalue (x, n);
1211	set_num_integer (x);	1232
1212	return x;	1233	return x;
1213	}	1234	}
1214		1235
1215	INTERFACE pointer	1236	INTERFACE pointer
1216	mk_real (SCHEME_P_ RVALUE n)	1237	mk_real (SCHEME_P_ RVALUE n)
1217	{	1238	{
		1239	#if USE_REAL
1218	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1240	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1219		1241
1220	set_typeflag (x, (T_NUMBER | T_ATOM));	1242	set_typeflag (x, (T_REAL | T_ATOM));
1221	rvalue_unchecked (x) = n;	1243	set_rvalue (x, n);
1222	set_num_real (x);	1244
1223	return x;	1245	return x;
		1246	#else
		1247	return mk_integer (SCHEME_A_ n);
		1248	#endif
1224	}	1249	}
1225		1250
1226	static pointer	1251	static pointer
1227	mk_number (SCHEME_P_ const num n)	1252	mk_number (SCHEME_P_ const num n)
1228	{	1253	{
		1254	#if USE_REAL
1229	if (num_is_fixnum (n))	1255	return num_is_fixnum (n)
		1256	? mk_integer (SCHEME_A_ num_ivalue (n))
		1257	: mk_real (SCHEME_A_ num_rvalue (n));
		1258	#else
1230	return mk_integer (SCHEME_A_ num_get_ivalue (n));	1259	return mk_integer (SCHEME_A_ num_ivalue (n));
1231	else	1260	#endif
1232	return mk_real (SCHEME_A_ num_get_rvalue (n));
1233	}	1261	}
1234		1262
1235	/* allocate name to string area */	1263	/* allocate name to string area */
1236	static char *	1264	static char *
1237	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)	1265	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
…		…
1296	{	1324	{
1297	return get_vector_object (SCHEME_A_ len, NIL);	1325	return get_vector_object (SCHEME_A_ len, NIL);
1298	}	1326	}
1299		1327
1300	INTERFACE void	1328	INTERFACE void
1301	fill_vector (pointer vec, pointer obj)	1329	fill_vector (pointer vec, uint32_t start, pointer obj)
1302	{	1330	{
1303	int i;	1331	int i;
1304		1332
1305	for (i = 0; i < vec->object.vector.length; i++)	1333	for (i = start; i < veclength (vec); i++)
1306	vecvalue (vec)[i] = obj;	1334	vecvalue (vec)[i] = obj;
1307	}	1335	}
1308		1336
1309	INTERFACE pointer	1337	INTERFACE pointer
1310	vector_elem (pointer vec, uint32_t ielem)	1338	vector_get (pointer vec, uint32_t ielem)
1311	{	1339	{
1312	return vecvalue(vec)[ielem];	1340	return vecvalue(vec)[ielem];
1313	}	1341	}
1314		1342
1315	INTERFACE void	1343	INTERFACE void
1316	set_vector_elem (pointer vec, uint32_t ielem, pointer a)	1344	vector_set (pointer vec, uint32_t ielem, pointer a)
1317	{	1345	{
1318	vecvalue(vec)[ielem] = a;	1346	vecvalue(vec)[ielem] = a;
1319	}	1347	}
1320		1348
1321	/* get new symbol */	1349	/* get new symbol */
…		…
1413	}	1441	}
1414	else if ((c == 'e') || (c == 'E'))	1442	else if ((c == 'e') || (c == 'E'))
1415	{	1443	{
1416	if (!has_fp_exp)	1444	if (!has_fp_exp)
1417	{	1445	{
1418	has_dec_point = 1; /* decimal point illegal	1446	has_dec_point = 1; /* decimal point illegal from now on */
1419	from now on */
1420	p++;	1447	p++;
1421		1448
1422	if ((*p == '-') || (*p == '+') || isdigit (*p))	1449	if ((*p == '-') || (*p == '+') || isdigit (*p))
1423	continue;	1450	continue;
1424	}	1451	}
…		…
1512		1539
1513	if (ecb_expect_false (is_vector (p)))	1540	if (ecb_expect_false (is_vector (p)))
1514	{	1541	{
1515	int i;	1542	int i;
1516		1543
1517	for (i = 0; i < p->object.vector.length; i++)	1544	for (i = 0; i < veclength (p); i++)
1518	mark (vecvalue (p)[i]);	1545	mark (vecvalue (p)[i]);
1519	}	1546	}
1520		1547
1521	if (is_atom (p))	1548	if (is_atom (p))
1522	goto E6;	1549	goto E6;
…		…
1620	if (is_mark (p))	1647	if (is_mark (p))
1621	clrmark (p);	1648	clrmark (p);
1622	else	1649	else
1623	{	1650	{
1624	/* reclaim cell */	1651	/* reclaim cell */
1625	if (typeflag (p) != T_FREE)	1652	if (typeflag (p) != T_PAIR)
1626	{	1653	{
1627	finalize_cell (SCHEME_A_ p);	1654	finalize_cell (SCHEME_A_ p);
1628	set_typeflag (p, T_FREE);	1655	set_typeflag (p, T_PAIR);
1629	set_car (p, NIL);	1656	set_car (p, NIL);
1630	}	1657	}
1631		1658
1632	++SCHEME_V->fcells;	1659	++SCHEME_V->fcells;
1633	set_cdr (p, SCHEME_V->free_cell);	1660	set_cdr (p, SCHEME_V->free_cell);
…		…
1635	}	1662	}
1636	}	1663	}
1637	}	1664	}
1638		1665
1639	if (SCHEME_V->gc_verbose)	1666	if (SCHEME_V->gc_verbose)
		1667	{
1640	xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");	1668	xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");
		1669	}
1641	}	1670	}
1642		1671
1643	static void	1672	static void
1644	finalize_cell (SCHEME_P_ pointer a)	1673	finalize_cell (SCHEME_P_ pointer a)
1645	{	1674	{
…		…
2232	}	2261	}
2233	}	2262	}
2234	}	2263	}
2235		2264
2236	/* check c is in chars */	2265	/* check c is in chars */
2237	static INLINE int	2266	ecb_inline int
2238	is_one_of (char *s, int c)	2267	is_one_of (char *s, int c)
2239	{	2268	{
2240	if (c == EOF)	2269	if (c == EOF)
2241	return 1;	2270	return 1;
2242		2271
2243	return !!strchr (s, c);	2272	return !!strchr (s, c);
2244	}	2273	}
2245		2274
2246	/* skip white characters */	2275	/* skip white characters */
2247	static INLINE int	2276	ecb_inline int
2248	skipspace (SCHEME_P)	2277	skipspace (SCHEME_P)
2249	{	2278	{
2250	int c, curr_line = 0;	2279	int c, curr_line = 0;
2251		2280
2252	do	2281	do
…		…
2480	{	2509	{
2481	p = SCHEME_V->strbuff;	2510	p = SCHEME_V->strbuff;
2482		2511
2483	if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */	2512	if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2484	{	2513	{
2485	if (num_is_integer (l))	2514	if (is_integer (l))
2486	xnum (p, ivalue_unchecked (l));	2515	xnum (p, ivalue_unchecked (l));
2487	#if USE_REAL	2516	#if USE_REAL
2488	else	2517	else
2489	{	2518	{
2490	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));	2519	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
…		…
2745	return 0;	2774	return 0;
2746	}	2775	}
2747	else if (is_number (a))	2776	else if (is_number (a))
2748	{	2777	{
2749	if (is_number (b))	2778	if (is_number (b))
2750	if (num_is_integer (a) == num_is_integer (b))
2751	return num_cmp (nvalue (a), nvalue (b)) == 0;	2779	return num_cmp (nvalue (a), nvalue (b)) == 0;
2752		2780
2753	return 0;	2781	return 0;
2754	}	2782	}
2755	else if (is_character (a))	2783	else if (is_character (a))
2756	{	2784	{
…		…
2823		2851
2824	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2852	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2825	setenvironment (SCHEME_V->envir);	2853	setenvironment (SCHEME_V->envir);
2826	}	2854	}
2827		2855
2828	static INLINE void	2856	static uint32_t
		2857	sym_hash (pointer sym, uint32_t size)
		2858	{
		2859	uintptr_t ptr = (uintptr_t)sym;
		2860
		2861	#if 0
		2862	/* tqable size is prime, so why mix */
		2863	ptr += ptr >> 32;
		2864	ptr += ptr >> 16;
		2865	ptr += ptr >> 8;
		2866	#endif
		2867
		2868	return ptr % size;
		2869	}
		2870
		2871	ecb_inline void
2829	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2872	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2830	{	2873	{
2831	pointer slot = immutable_cons (variable, value);	2874	pointer slot = immutable_cons (variable, value);
2832		2875
2833	if (is_vector (car (env)))	2876	if (is_vector (car (env)))
2834	{	2877	{
2835	int location = hash_fn (symname (variable), veclength (car (env)));	2878	int location = sym_hash (variable, veclength (car (env)));
2836
2837	set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));	2879	vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2838	}	2880	}
2839	else	2881	else
2840	set_car (env, immutable_cons (slot, car (env)));	2882	set_car (env, immutable_cons (slot, car (env)));
2841	}	2883	}
2842		2884
2843	static pointer	2885	static pointer
2844	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)	2886	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2845	{	2887	{
2846	pointer x, y;	2888	pointer x, y;
2847	int location;
2848		2889
2849	for (x = env; x != NIL; x = cdr (x))	2890	for (x = env; x != NIL; x = cdr (x))
2850	{	2891	{
2851	if (is_vector (car (x)))	2892	if (is_vector (car (x)))
2852	{	2893	{
2853	location = hash_fn (symname (hdl), veclength (car (x)));	2894	int location = sym_hash (hdl, veclength (car (x)));
2854	y = vector_elem (car (x), location);	2895	y = vector_get (car (x), location);
2855	}	2896	}
2856	else	2897	else
2857	y = car (x);	2898	y = car (x);
2858		2899
2859	for (; y != NIL; y = cdr (y))	2900	for (; y != NIL; y = cdr (y))
2860	if (caar (y) == hdl)	2901	if (caar (y) == hdl)
2861	break;	2902	break;
2862		2903
2863	if (y != NIL)	2904	if (y != NIL)
		2905	return car (y);
		2906
		2907	if (!all)
2864	break;	2908	break;
2865
2866	if (!all)
2867	return NIL;
2868	}	2909	}
2869
2870	if (x != NIL)
2871	return car (y);
2872		2910
2873	return NIL;	2911	return NIL;
2874	}	2912	}
2875		2913
2876	#else /* USE_ALIST_ENV */	2914	#else /* USE_ALIST_ENV */
2877		2915
2878	static INLINE void	2916	ecb_inline void
2879	new_frame_in_env (SCHEME_P_ pointer old_env)	2917	new_frame_in_env (SCHEME_P_ pointer old_env)
2880	{	2918	{
2881	SCHEME_V->envir = immutable_cons (NIL, old_env);	2919	SCHEME_V->envir = immutable_cons (NIL, old_env);
2882	setenvironment (SCHEME_V->envir);	2920	setenvironment (SCHEME_V->envir);
2883	}	2921	}
2884		2922
2885	static INLINE void	2923	ecb_inline void
2886	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2924	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2887	{	2925	{
2888	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2926	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2889	}	2927	}
2890		2928
…		…
2898	for (y = car (x); y != NIL; y = cdr (y))	2936	for (y = car (x); y != NIL; y = cdr (y))
2899	if (caar (y) == hdl)	2937	if (caar (y) == hdl)
2900	break;	2938	break;
2901		2939
2902	if (y != NIL)	2940	if (y != NIL)
		2941	return car (y);
2903	break;	2942	break;
2904		2943
2905	if (!all)	2944	if (!all)
2906	return NIL;	2945	break;
2907	}	2946	}
2908
2909	if (x != NIL)
2910	return car (y);
2911		2947
2912	return NIL;	2948	return NIL;
2913	}	2949	}
2914		2950
2915	#endif /* USE_ALIST_ENV else */	2951	#endif /* USE_ALIST_ENV else */
2916		2952
2917	static INLINE void	2953	ecb_inline void
2918	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2954	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2919	{	2955	{
2920	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);	2956	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2921	}	2957	}
2922		2958
2923	static INLINE void	2959	ecb_inline void
2924	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2960	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2925	{	2961	{
2926	set_cdr (slot, value);	2962	set_cdr (slot, value);
2927	}	2963	}
2928		2964
2929	static INLINE pointer	2965	ecb_inline pointer
2930	slot_value_in_env (pointer slot)	2966	slot_value_in_env (pointer slot)
2931	{	2967	{
2932	return cdr (slot);	2968	return cdr (slot);
2933	}	2969	}
2934		2970
…		…
3062	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3098	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3063		3099
3064	return 0;	3100	return 0;
3065	}	3101	}
3066		3102
3067	static INLINE void	3103	ecb_inline void
3068	dump_stack_reset (SCHEME_P)	3104	dump_stack_reset (SCHEME_P)
3069	{	3105	{
3070	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */	3106	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3071	SCHEME_V->dump = (pointer)+0;	3107	SCHEME_V->dump = (pointer)+0;
3072	}	3108	}
3073		3109
3074	static INLINE void	3110	ecb_inline void
3075	dump_stack_initialize (SCHEME_P)	3111	dump_stack_initialize (SCHEME_P)
3076	{	3112	{
3077	SCHEME_V->dump_size = 0;	3113	SCHEME_V->dump_size = 0;
3078	SCHEME_V->dump_base = 0;	3114	SCHEME_V->dump_base = 0;
3079	dump_stack_reset (SCHEME_A);	3115	dump_stack_reset (SCHEME_A);
…		…
3132	int i = 0;	3168	int i = 0;
3133	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3169	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3134		3170
3135	while (cont != NIL)	3171	while (cont != NIL)
3136	{	3172	{
3137	frame->op = ivalue (car (cont)); cont = cdr (cont);	3173	frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont);
3138	frame->args = car (cont) ; cont = cdr (cont);	3174	frame->args = car (cont) ; cont = cdr (cont);
3139	frame->envir = car (cont) ; cont = cdr (cont);	3175	frame->envir = car (cont) ; cont = cdr (cont);
3140	frame->code = car (cont) ; cont = cdr (cont);	3176	frame->code = car (cont) ; cont = cdr (cont);
3141		3177
3142	++frame;	3178	++frame;
3143	++i;	3179	++i;
3144	}	3180	}
3145		3181
3146	SCHEME_V->dump = (pointer)(uintptr_t)i;	3182	SCHEME_V->dump = (pointer)(uintptr_t)i;
3147	}	3183	}
3148		3184
3149	#else	3185	#else
3150		3186
3151	static INLINE void	3187	ecb_inline void
3152	dump_stack_reset (SCHEME_P)	3188	dump_stack_reset (SCHEME_P)
3153	{	3189	{
3154	SCHEME_V->dump = NIL;	3190	SCHEME_V->dump = NIL;
3155	}	3191	}
3156		3192
3157	static INLINE void	3193	ecb_inline void
3158	dump_stack_initialize (SCHEME_P)	3194	dump_stack_initialize (SCHEME_P)
3159	{	3195	{
3160	dump_stack_reset (SCHEME_A);	3196	dump_stack_reset (SCHEME_A);
3161	}	3197	}
3162		3198
…		…
3174	SCHEME_V->value = a;	3210	SCHEME_V->value = a;
3175		3211
3176	if (dump == NIL)	3212	if (dump == NIL)
3177	return -1;	3213	return -1;
3178		3214
3179	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);	3215	SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump);
3180	SCHEME_V->args = car (dump) ; dump = cdr (dump);	3216	SCHEME_V->args = car (dump) ; dump = cdr (dump);
3181	SCHEME_V->envir = car (dump) ; dump = cdr (dump);	3217	SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3182	SCHEME_V->code = car (dump) ; dump = cdr (dump);	3218	SCHEME_V->code = car (dump) ; dump = cdr (dump);
3183		3219
3184	SCHEME_V->dump = dump;	3220	SCHEME_V->dump = dump;
3185		3221
3186	return 0;	3222	return 0;
3187	}	3223	}
…		…
3393		3429
3394	case OP_TRACING:	3430	case OP_TRACING:
3395	{	3431	{
3396	int tr = SCHEME_V->tracing;	3432	int tr = SCHEME_V->tracing;
3397		3433
3398	SCHEME_V->tracing = ivalue (car (args));	3434	SCHEME_V->tracing = ivalue_unchecked (car (args));
3399	s_return (mk_integer (SCHEME_A_ tr));	3435	s_return (mk_integer (SCHEME_A_ tr));
3400	}	3436	}
3401		3437
3402	#endif	3438	#endif
3403		3439
…		…
3912	SCHEME_V->code = car (args);	3948	SCHEME_V->code = car (args);
3913	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);	3949	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3914	s_goto (OP_APPLY);	3950	s_goto (OP_APPLY);
3915	}	3951	}
3916		3952
3917	abort ();	3953	if (USE_ERROR_CHECKING) abort ();
3918	}	3954	}
3919		3955
3920	static int	3956	static int
3921	opexe_1 (SCHEME_P_ enum scheme_opcodes op)	3957	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3922	{	3958	{
3923	pointer args = SCHEME_V->args;	3959	pointer args = SCHEME_V->args;
3924	pointer x = car (args);	3960	pointer x = car (args);
3925	num v;	3961	num v;
3926		3962
3927	#if USE_MATH
3928	RVALUE dd;
3929	#endif
3930
3931	switch (op)	3963	switch (op)
3932	{	3964	{
3933	#if USE_MATH	3965	#if USE_MATH
3934	case OP_INEX2EX: /* inexact->exact */	3966	case OP_INEX2EX: /* inexact->exact */
		3967	{
3935	if (num_is_integer (x))	3968	if (is_integer (x))
3936	s_return (x);	3969	s_return (x);
3937	else if (modf (rvalue_unchecked (x), &dd) == 0)	3970
		3971	RVALUE r = rvalue_unchecked (x);
		3972
		3973	if (r == (RVALUE)(IVALUE)r)
3938	s_return (mk_integer (SCHEME_A_ ivalue (x)));	3974	s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x)));
3939	else	3975	else
3940	Error_1 ("inexact->exact: not integral:", x);	3976	Error_1 ("inexact->exact: not integral:", x);
		3977	}
3941		3978
3942	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));	3979	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))));	3980	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))));	3981	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))));	3982	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
…		…
3963	{	4000	{
3964	RVALUE result;	4001	RVALUE result;
3965	int real_result = 1;	4002	int real_result = 1;
3966	pointer y = cadr (args);	4003	pointer y = cadr (args);
3967		4004
3968	if (num_is_integer (x) && num_is_integer (y))	4005	if (is_integer (x) && is_integer (y))
3969	real_result = 0;	4006	real_result = 0;
3970		4007
3971	/* This 'if' is an R5RS compatibility fix. */	4008	/* This 'if' is an R5RS compatibility fix. */
3972	/* NOTE: Remove this 'if' fix for R6RS. */	4009	/* NOTE: Remove this 'if' fix for R6RS. */
3973	if (rvalue (x) == 0 && rvalue (y) < 0)	4010	if (rvalue (x) == 0 && rvalue (y) < 0)
…		…
3979	/* If the test fails, result is too big for integer. */	4016	/* If the test fails, result is too big for integer. */
3980	if (!real_result)	4017	if (!real_result)
3981	{	4018	{
3982	long result_as_long = result;	4019	long result_as_long = result;
3983		4020
3984	if (result != (RVALUE) result_as_long)	4021	if (result != result_as_long)
3985	real_result = 1;	4022	real_result = 1;
3986	}	4023	}
3987		4024
3988	if (real_result)	4025	if (real_result)
3989	s_return (mk_real (SCHEME_A_ result));	4026	s_return (mk_real (SCHEME_A_ result));
…		…
3994	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));	4031	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))));	4032	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
3996		4033
3997	case OP_TRUNCATE:	4034	case OP_TRUNCATE:
3998	{	4035	{
3999	RVALUE rvalue_of_x;	4036	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)));	4037	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	}	4038	}
4008		4039
4009	case OP_ROUND:	4040	case OP_ROUND:
4010	if (num_is_integer (x))	4041	if (is_integer (x))
4011	s_return (x);	4042	s_return (x);
4012		4043
4013	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));	4044	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4014	#endif	4045	#endif
4015		4046
4016	case OP_ADD: /* + */	4047	case OP_ADD: /* + */
4017	v = num_zero;	4048	v = num_zero;
4018		4049
4019	for (x = args; x != NIL; x = cdr (x))	4050	for (x = args; x != NIL; x = cdr (x))
4020	v = num_op ('+', v, nvalue (car (x)));	4051	v = num_op (NUM_ADD, v, nvalue (car (x)));
4021		4052
4022	s_return (mk_number (SCHEME_A_ v));	4053	s_return (mk_number (SCHEME_A_ v));
4023		4054
4024	case OP_MUL: /* * */	4055	case OP_MUL: /* * */
4025	v = num_one;	4056	v = num_one;
4026		4057
4027	for (x = args; x != NIL; x = cdr (x))	4058	for (x = args; x != NIL; x = cdr (x))
4028	v = num_op ('*', v, nvalue (car (x)));	4059	v = num_op (NUM_MUL, v, nvalue (car (x)));
4029		4060
4030	s_return (mk_number (SCHEME_A_ v));	4061	s_return (mk_number (SCHEME_A_ v));
4031		4062
4032	case OP_SUB: /* - */	4063	case OP_SUB: /* - */
4033	if (cdr (args) == NIL)	4064	if (cdr (args) == NIL)
…		…
4040	x = cdr (args);	4071	x = cdr (args);
4041	v = nvalue (car (args));	4072	v = nvalue (car (args));
4042	}	4073	}
4043		4074
4044	for (; x != NIL; x = cdr (x))	4075	for (; x != NIL; x = cdr (x))
4045	v = num_op ('-', v, nvalue (car (x)));	4076	v = num_op (NUM_SUB, v, nvalue (car (x)));
4046		4077
4047	s_return (mk_number (SCHEME_A_ v));	4078	s_return (mk_number (SCHEME_A_ v));
4048		4079
4049	case OP_DIV: /* / */	4080	case OP_DIV: /* / */
4050	if (cdr (args) == NIL)	4081	if (cdr (args) == NIL)
…		…
4057	x = cdr (args);	4088	x = cdr (args);
4058	v = nvalue (car (args));	4089	v = nvalue (car (args));
4059	}	4090	}
4060		4091
4061	for (; x != NIL; x = cdr (x))	4092	for (; x != NIL; x = cdr (x))
4062	{
4063	if (!is_zero_rvalue (rvalue (car (x))))	4093	if (!is_zero_rvalue (rvalue (car (x))))
4064	v = num_div (v, nvalue (car (x)));	4094	v = num_div (v, nvalue (car (x)));
4065	else	4095	else
4066	Error_0 ("/: division by zero");	4096	Error_0 ("/: division by zero");
4067	}
4068		4097
4069	s_return (mk_number (SCHEME_A_ v));	4098	s_return (mk_number (SCHEME_A_ v));
4070		4099
4071	case OP_INTDIV: /* quotient */	4100	case OP_INTDIV: /* quotient */
4072	if (cdr (args) == NIL)	4101	if (cdr (args) == NIL)
…		…
4081	}	4110	}
4082		4111
4083	for (; x != NIL; x = cdr (x))	4112	for (; x != NIL; x = cdr (x))
4084	{	4113	{
4085	if (ivalue (car (x)) != 0)	4114	if (ivalue (car (x)) != 0)
4086	v = num_op ('/', v, nvalue (car (x)));	4115	v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4087	else	4116	else
4088	Error_0 ("quotient: division by zero");	4117	Error_0 ("quotient: division by zero");
4089	}	4118	}
4090		4119
4091	s_return (mk_number (SCHEME_A_ v));	4120	s_return (mk_number (SCHEME_A_ v));
…		…
4137	}	4166	}
4138	else	4167	else
4139	Error_0 ("set-cdr!: unable to alter immutable pair");	4168	Error_0 ("set-cdr!: unable to alter immutable pair");
4140		4169
4141	case OP_CHAR2INT: /* char->integer */	4170	case OP_CHAR2INT: /* char->integer */
4142	s_return (mk_integer (SCHEME_A_ ivalue (x)));	4171	s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x)));
4143		4172
4144	case OP_INT2CHAR: /* integer->char */	4173	case OP_INT2CHAR: /* integer->char */
4145	s_return (mk_character (SCHEME_A_ ivalue (x)));	4174	s_return (mk_character (SCHEME_A_ ivalue_unchecked (x)));
4146		4175
4147	case OP_CHARUPCASE:	4176	case OP_CHARUPCASE:
4148	{	4177	{
4149	unsigned char c = ivalue (x);	4178	unsigned char c = ivalue_unchecked (x);
4150	c = toupper (c);	4179	c = toupper (c);
4151	s_return (mk_character (SCHEME_A_ c));	4180	s_return (mk_character (SCHEME_A_ c));
4152	}	4181	}
4153		4182
4154	case OP_CHARDNCASE:	4183	case OP_CHARDNCASE:
4155	{	4184	{
4156	unsigned char c = ivalue (x);	4185	unsigned char c = ivalue_unchecked (x);
4157	c = tolower (c);	4186	c = tolower (c);
4158	s_return (mk_character (SCHEME_A_ c));	4187	s_return (mk_character (SCHEME_A_ c));
4159	}	4188	}
4160		4189
4161	case OP_STR2SYM: /* string->symbol */	4190	case OP_STR2SYM: /* string->symbol */
…		…
4238	Error_1 ("atom->string: not an atom:", x);	4267	Error_1 ("atom->string: not an atom:", x);
4239	}	4268	}
4240		4269
4241	case OP_MKSTRING: /* make-string */	4270	case OP_MKSTRING: /* make-string */
4242	{	4271	{
4243	int fill = ' ';	4272	int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' ';
4244	int len;
4245
4246	len = ivalue (x);	4273	int len = ivalue_unchecked (x);
4247
4248	if (cdr (args) != NIL)
4249	fill = charvalue (cadr (args));
4250		4274
4251	s_return (mk_empty_string (SCHEME_A_ len, fill));	4275	s_return (mk_empty_string (SCHEME_A_ len, fill));
4252	}	4276	}
4253		4277
4254	case OP_STRLEN: /* string-length */	4278	case OP_STRLEN: /* string-length */
4255	s_return (mk_integer (SCHEME_A_ strlength (x)));	4279	s_return (mk_integer (SCHEME_A_ strlength (x)));
4256		4280
4257	case OP_STRREF: /* string-ref */	4281	case OP_STRREF: /* string-ref */
4258	{	4282	{
4259	char *str;
4260	int index;
4261
4262	str = strvalue (x);	4283	char *str = strvalue (x);
4263
4264	index = ivalue (cadr (args));	4284	int index = ivalue_unchecked (cadr (args));
4265		4285
4266	if (index >= strlength (x))	4286	if (index >= strlength (x))
4267	Error_1 ("string-ref: out of bounds:", cadr (args));	4287	Error_1 ("string-ref: out of bounds:", cadr (args));
4268		4288
4269	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));	4289	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4270	}	4290	}
4271		4291
4272	case OP_STRSET: /* string-set! */	4292	case OP_STRSET: /* string-set! */
4273	{	4293	{
4274	char *str;	4294	char *str = strvalue (x);
4275	int index;	4295	int index = ivalue_unchecked (cadr (args));
4276	int c;	4296	int c;
4277		4297
4278	if (is_immutable (x))	4298	if (is_immutable (x))
4279	Error_1 ("string-set!: unable to alter immutable string:", x);	4299	Error_1 ("string-set!: unable to alter immutable string:", x);
4280
4281	str = strvalue (x);
4282
4283	index = ivalue (cadr (args));
4284		4300
4285	if (index >= strlength (x))	4301	if (index >= strlength (x))
4286	Error_1 ("string-set!: out of bounds:", cadr (args));	4302	Error_1 ("string-set!: out of bounds:", cadr (args));
4287		4303
4288	c = charvalue (caddr (args));	4304	c = charvalue (caddr (args));
…		…
4311	s_return (newstr);	4327	s_return (newstr);
4312	}	4328	}
4313		4329
4314	case OP_SUBSTR: /* substring */	4330	case OP_SUBSTR: /* substring */
4315	{	4331	{
4316	char *str;	4332	char *str = strvalue (x);
4317	int index0;	4333	int index0 = ivalue_unchecked (cadr (args));
4318	int index1;	4334	int index1;
4319	int len;	4335	int len;
4320		4336
4321	str = strvalue (x);
4322
4323	index0 = ivalue (cadr (args));
4324
4325	if (index0 > strlength (x))	4337	if (index0 > strlength (x))
4326	Error_1 ("substring: start out of bounds:", cadr (args));	4338	Error_1 ("substring: start out of bounds:", cadr (args));
4327		4339
4328	if (cddr (args) != NIL)	4340	if (cddr (args) != NIL)
4329	{	4341	{
4330	index1 = ivalue (caddr (args));	4342	index1 = ivalue_unchecked (caddr (args));
4331		4343
4332	if (index1 > strlength (x) || index1 < index0)	4344	if (index1 > strlength (x) || index1 < index0)
4333	Error_1 ("substring: end out of bounds:", caddr (args));	4345	Error_1 ("substring: end out of bounds:", caddr (args));
4334	}	4346	}
4335	else	4347	else
…		…
4358	if (SCHEME_V->no_memory)	4370	if (SCHEME_V->no_memory)
4359	s_return (S_SINK);	4371	s_return (S_SINK);
4360	#endif	4372	#endif
4361		4373
4362	for (x = args, i = 0; is_pair (x); x = cdr (x), i++)	4374	for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4363	set_vector_elem (vec, i, car (x));	4375	vector_set (vec, i, car (x));
4364		4376
4365	s_return (vec);	4377	s_return (vec);
4366	}	4378	}
4367		4379
4368	case OP_MKVECTOR: /* make-vector */	4380	case OP_MKVECTOR: /* make-vector */
4369	{	4381	{
4370	pointer fill = NIL;	4382	pointer fill = NIL;
4371	int len;
4372	pointer vec;	4383	pointer vec;
4373
4374	len = ivalue (x);	4384	int len = ivalue_unchecked (x);
4375		4385
4376	if (cdr (args) != NIL)	4386	if (cdr (args) != NIL)
4377	fill = cadr (args);	4387	fill = cadr (args);
4378		4388
4379	vec = mk_vector (SCHEME_A_ len);	4389	vec = mk_vector (SCHEME_A_ len);
…		…
4382	if (SCHEME_V->no_memory)	4392	if (SCHEME_V->no_memory)
4383	s_return (S_SINK);	4393	s_return (S_SINK);
4384	#endif	4394	#endif
4385		4395
4386	if (fill != NIL)	4396	if (fill != NIL)
4387	fill_vector (vec, fill);	4397	fill_vector (vec, 0, fill);
4388		4398
4389	s_return (vec);	4399	s_return (vec);
4390	}	4400	}
4391		4401
4392	case OP_VECLEN: /* vector-length */	4402	case OP_VECLEN: /* vector-length */
4393	s_return (mk_integer (SCHEME_A_ veclength (x)));	4403	s_return (mk_integer (SCHEME_A_ veclength (x)));
4394		4404
4395	case OP_VECREF: /* vector-ref */	4405	case OP_VECREF: /* vector-ref */
4396	{	4406	{
4397	int index;
4398
4399	index = ivalue (cadr (args));	4407	int index = ivalue_unchecked (cadr (args));
4400		4408
4401	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)	4409	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4402	Error_1 ("vector-ref: out of bounds:", cadr (args));	4410	Error_1 ("vector-ref: out of bounds:", cadr (args));
4403		4411
4404	s_return (vector_elem (x, index));	4412	s_return (vector_get (x, index));
4405	}	4413	}
4406		4414
4407	case OP_VECSET: /* vector-set! */	4415	case OP_VECSET: /* vector-set! */
4408	{	4416	{
4409	int index;	4417	int index = ivalue_unchecked (cadr (args));
4410		4418
4411	if (is_immutable (x))	4419	if (is_immutable (x))
4412	Error_1 ("vector-set!: unable to alter immutable vector:", x);	4420	Error_1 ("vector-set!: unable to alter immutable vector:", x);
4413		4421
4414	index = ivalue (cadr (args));
4415
4416	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)	4422	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4417	Error_1 ("vector-set!: out of bounds:", cadr (args));	4423	Error_1 ("vector-set!: out of bounds:", cadr (args));
4418		4424
4419	set_vector_elem (x, index, caddr (args));	4425	vector_set (x, index, caddr (args));
4420	s_return (x);	4426	s_return (x);
4421	}	4427	}
4422	}	4428	}
4423		4429
4424	abort ();	4430	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	}	4431	}
4480		4432
4481	static int	4433	static int
4482	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	4434	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4483	{	4435	{
…		…
4529	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;	4481	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4530	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */	4482	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4531	case OP_CHARP: /* char? */ r = is_character (a) ; break;	4483	case OP_CHARP: /* char? */ r = is_character (a) ; break;
4532		4484
4533	#if USE_CHAR_CLASSIFIERS	4485	#if USE_CHAR_CLASSIFIERS
4534	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue (a)); break;	4486	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4535	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue (a)); break;	4487	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4536	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue (a)); break;	4488	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
4537	case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue (a)); break;	4489	case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break;
4538	case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue (a)); break;	4490	case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break;
4539	#endif	4491	#endif
4540		4492
4541	#if USE_PORTS	4493	#if USE_PORTS
4542	case OP_PORTP: /* port? */ r = is_port (a) ; break;	4494	case OP_PORTP: /* port? */ r = is_port (a) ; break;
4543	case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;	4495	case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
…		…
4744		4696
4745	case OP_NEWSEGMENT: /* new-segment */	4697	case OP_NEWSEGMENT: /* new-segment */
4746	if (!is_pair (args) || !is_number (a))	4698	if (!is_pair (args) || !is_number (a))
4747	Error_0 ("new-segment: argument must be a number");	4699	Error_0 ("new-segment: argument must be a number");
4748		4700
4749	alloc_cellseg (SCHEME_A_ (int)ivalue (a));	4701	alloc_cellseg (SCHEME_A_ ivalue (a));
4750		4702
4751	s_return (S_T);	4703	s_return (S_T);
4752		4704
4753	case OP_OBLIST: /* oblist */	4705	case OP_OBLIST: /* oblist */
4754	s_return (oblist_all_symbols (SCHEME_A));	4706	s_return (oblist_all_symbols (SCHEME_A));
…		…
4783	break;	4735	break;
4784	}	4736	}
4785		4737
4786	p = port_from_filename (SCHEME_A_ strvalue (a), prop);	4738	p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4787		4739
4788	if (p == NIL)	4740	s_return (p == NIL ? S_F : p);
4789	s_return (S_F);
4790
4791	s_return (p);
4792	}	4741	}
4793		4742
4794	# if USE_STRING_PORTS	4743	# if USE_STRING_PORTS
4795		4744
4796	case OP_OPEN_INSTRING: /* open-input-string */	4745	case OP_OPEN_INSTRING: /* open-input-string */
…		…
4811	}	4760	}
4812		4761
4813	p = port_from_string (SCHEME_A_ strvalue (a),	4762	p = port_from_string (SCHEME_A_ strvalue (a),
4814	strvalue (a) + strlength (a), prop);	4763	strvalue (a) + strlength (a), prop);
4815		4764
4816	if (p == NIL)	4765	s_return (p == NIL ? S_F : p);
4817	s_return (S_F);
4818
4819	s_return (p);
4820	}	4766	}
4821		4767
4822	case OP_OPEN_OUTSTRING: /* open-output-string */	4768	case OP_OPEN_OUTSTRING: /* open-output-string */
4823	{	4769	{
4824	pointer p;	4770	pointer p;
4825		4771
4826	if (a == NIL)	4772	if (a == NIL)
4827	{
4828	p = port_from_scratch (SCHEME_A);	4773	p = port_from_scratch (SCHEME_A);
4829
4830	if (p == NIL)
4831	s_return (S_F);
4832	}
4833	else	4774	else
4834	{
4835	p = port_from_string (SCHEME_A_ strvalue (a),	4775	p = port_from_string (SCHEME_A_ strvalue (a),
4836	strvalue (a) + strlength (a), port_output);	4776	strvalue (a) + strlength (a), port_output);
4837		4777
4838	if (p == NIL)	4778	s_return (p == NIL ? S_F : p);
4839	s_return (S_F);
4840	}
4841
4842	s_return (p);
4843	}	4779	}
4844		4780
4845	case OP_GET_OUTSTRING: /* get-output-string */	4781	case OP_GET_OUTSTRING: /* get-output-string */
4846	{	4782	{
4847	port *p;	4783	port *p;
…		…
4886	case OP_CURR_ENV: /* current-environment */	4822	case OP_CURR_ENV: /* current-environment */
4887	s_return (SCHEME_V->envir);	4823	s_return (SCHEME_V->envir);
4888		4824
4889	}	4825	}
4890		4826
4891	abort ();	4827	if (USE_ERROR_CHECKING) abort ();
4892	}	4828	}
4893		4829
4894	static int	4830	static int
4895	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4831	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4896	{	4832	{
…		…
5215	putstr (SCHEME_A_ ")");	5151	putstr (SCHEME_A_ ")");
5216	s_return (S_T);	5152	s_return (S_T);
5217	}	5153	}
5218	else	5154	else
5219	{	5155	{
5220	pointer elem = vector_elem (vec, i);	5156	pointer elem = vector_get (vec, i);
5221		5157
5222	ivalue_unchecked (cdr (args)) = i + 1;	5158	ivalue_unchecked (cdr (args)) = i + 1;
5223	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);	5159	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5224	SCHEME_V->args = elem;	5160	SCHEME_V->args = elem;
5225		5161
…		…
5229	s_goto (OP_P0LIST);	5165	s_goto (OP_P0LIST);
5230	}	5166	}
5231	}	5167	}
5232	}	5168	}
5233		5169
5234	abort ();	5170	if (USE_ERROR_CHECKING) abort ();
5235	}	5171	}
5236		5172
5237	static int	5173	static int
5238	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5174	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5239	{	5175	{
…		…
5292		5228
5293	case OP_MACROP: /* macro? */	5229	case OP_MACROP: /* macro? */
5294	s_retbool (is_macro (a));	5230	s_retbool (is_macro (a));
5295	}	5231	}
5296		5232
5297	abort ();	5233	if (USE_ERROR_CHECKING) abort ();
5298	}	5234	}
5299		5235
5300	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */	5236	/* 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);	5237	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5302		5238
5303	typedef int (*test_predicate)(pointer);	5239	typedef int (*test_predicate)(pointer);
5304	static int	5240	static int
5305	is_any (pointer p)	5241	tst_any (pointer p)
5306	{	5242	{
5307	return 1;	5243	return 1;
5308	}	5244	}
5309		5245
5310	static int	5246	static int
5311	is_nonneg (pointer p)	5247	tst_inonneg (pointer p)
5312	{	5248	{
5313	return ivalue (p) >= 0 && is_integer (p);	5249	return is_integer (p) && ivalue_unchecked (p) >= 0;
5314	}	5250	}
5315		5251
5316	static int	5252	static int
5317	tst_is_list (pointer p)	5253	tst_is_list (SCHEME_P_ pointer p)
5318	{	5254	{
5319	return p == NIL || is_pair (p);	5255	return p == NIL || is_pair (p);
5320	}	5256	}
5321		5257
5322	/* Correspond carefully with following defines! */	5258	/* Correspond carefully with following defines! */
5323	static struct	5259	static struct
5324	{	5260	{
5325	test_predicate fct;	5261	test_predicate fct;
5326	const char *kind;	5262	const char *kind;
5327	} tests[] =	5263	} tests[] = {
5328	{
5329	{ is_any, 0 },	5264	{ tst_any , 0 },
5330	{ is_string, "string" },	5265	{ is_string , "string" },
5331	{ is_symbol, "symbol" },	5266	{ is_symbol , "symbol" },
5332	{ is_port, "port" },	5267	{ is_port , "port" },
5333	{ is_inport, "input port" },	5268	{ is_inport , "input port" },
5334	{ is_outport, "output port" },	5269	{ is_outport , "output port" },
5335	{ is_environment, "environment" },	5270	{ is_environment, "environment" },
5336	{ is_pair, "pair" },	5271	{ is_pair , "pair" },
5337	{ tst_is_list, "pair or '()" },	5272	{ 0 , "pair or '()" },
5338	{ is_character, "character" },	5273	{ is_character , "character" },
5339	{ is_vector, "vector" },	5274	{ is_vector , "vector" },
5340	{ is_number, "number" },	5275	{ is_number , "number" },
5341	{ is_integer, "integer" },	5276	{ is_integer , "integer" },
5342	{ is_nonneg, "non-negative integer" }	5277	{ tst_inonneg , "non-negative integer" }
5343	};	5278	};
5344		5279
5345	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */	5280	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5346	#define TST_ANY "\001"	5281	#define TST_ANY "\001"
5347	#define TST_STRING "\002"	5282	#define TST_STRING "\002"
…		…
5388	typedef struct	5323	typedef struct
5389	{	5324	{
5390	uint8_t func;	5325	uint8_t func;
5391	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */	5326	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
5392	uint8_t builtin;	5327	uint8_t builtin;
		5328	#if USE_ERROR_CHECKING
5393	uint8_t min_arity;	5329	uint8_t min_arity;
5394	uint8_t max_arity;	5330	uint8_t max_arity;
5395	char arg_tests_encoding[3];	5331	char arg_tests_encoding[3];
		5332	#endif
5396	} op_code_info;	5333	} op_code_info;
5397		5334
5398	static const op_code_info dispatch_table[] = {	5335	static const op_code_info dispatch_table[] = {
		5336	#if USE_ERROR_CHECKING
5399	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },	5337	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
		5338	#else
		5339	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 },
		5340	#endif
5400	#include "opdefines.h"	5341	#include "opdefines.h"
5401	#undef OP_DEF	5342	#undef OP_DEF
5402	{0}	5343	{0}
5403	};	5344	};
5404		5345
5405	/* kernel of this interpreter */	5346	/* kernel of this interpreter */
5406	static void	5347	static void ecb_hot
5407	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5348	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5408	{	5349	{
5409	SCHEME_V->op = op;	5350	SCHEME_V->op = op;
5410		5351
5411	for (;;)	5352	for (;;)
…		…
5446	{	5387	{
5447	pointer arg = car (arglist);	5388	pointer arg = car (arglist);
5448		5389
5449	j = t[0];	5390	j = t[0];
5450		5391
		5392	/*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */
		5393	if (j == TST_LIST[0])
		5394	{
		5395	if (!tst_is_list (SCHEME_A_ arg))
		5396	break;
		5397	}
		5398	else
		5399	{
5451	if (!tests[j - 1].fct (arg))	5400	if (!tests[j - 1].fct (arg))
5452	break;	5401	break;
		5402	}
5453		5403
5454	if (t[1]) /* last test is replicated as necessary */	5404	if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */
5455	t++;	5405	t++;
5456		5406
5457	arglist = cdr (arglist);	5407	arglist = cdr (arglist);
5458	i++;	5408	i++;
5459	}	5409	}
…		…
5514	mk_proc (SCHEME_P_ enum scheme_opcodes op)	5464	mk_proc (SCHEME_P_ enum scheme_opcodes op)
5515	{	5465	{
5516	pointer y = get_cell (SCHEME_A_ NIL, NIL);	5466	pointer y = get_cell (SCHEME_A_ NIL, NIL);
5517	set_typeflag (y, (T_PROC | T_ATOM));	5467	set_typeflag (y, (T_PROC | T_ATOM));
5518	ivalue_unchecked (y) = op;	5468	ivalue_unchecked (y) = op;
5519	set_num_integer (y);
5520	return y;	5469	return y;
5521	}	5470	}
5522		5471
5523	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */	5472	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5524	static int	5473	static int
…		…
5589	return OP_C0STREAM; /* cons-stream */	5538	return OP_C0STREAM; /* cons-stream */
5590	}	5539	}
5591	}	5540	}
5592		5541
5593	#if USE_MULTIPLICITY	5542	#if USE_MULTIPLICITY
5594	scheme *	5543	ecb_cold scheme *
5595	scheme_init_new ()	5544	scheme_init_new ()
5596	{	5545	{
5597	scheme *sc = malloc (sizeof (scheme));	5546	scheme *sc = malloc (sizeof (scheme));
5598		5547
5599	if (!scheme_init (SCHEME_A))	5548	if (!scheme_init (SCHEME_A))
…		…
5604	else	5553	else
5605	return sc;	5554	return sc;
5606	}	5555	}
5607	#endif	5556	#endif
5608		5557
5609	int	5558	ecb_cold int
5610	scheme_init (SCHEME_P)	5559	scheme_init (SCHEME_P)
5611	{	5560	{
5612	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	5561	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5613	pointer x;	5562	pointer x;
5614		5563
…		…
5739	scheme_set_external_data (SCHEME_P_ void *p)	5688	scheme_set_external_data (SCHEME_P_ void *p)
5740	{	5689	{
5741	SCHEME_V->ext_data = p;	5690	SCHEME_V->ext_data = p;
5742	}	5691	}
5743		5692
5744	void	5693	ecb_cold void
5745	scheme_deinit (SCHEME_P)	5694	scheme_deinit (SCHEME_P)
5746	{	5695	{
5747	int i;	5696	int i;
5748		5697
5749	#if SHOW_ERROR_LINE	5698	#if SHOW_ERROR_LINE

Diff Legend

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