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.34 by root, Sat Nov 28 22:14:49 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
…		…
1056	return x;	1079	return x;
1057	}	1080	}
1058		1081
1059	/* ========== oblist implementation ========== */	1082	/* ========== oblist implementation ========== */
1060		1083
		1084	static pointer
		1085	generate_symbol (SCHEME_P_ const char *name)
		1086	{
		1087	pointer x = mk_string (SCHEME_A_ name);
		1088	setimmutable (x);
		1089	x = immutable_cons (x, NIL);
		1090	set_typeflag (x, T_SYMBOL);
		1091	return x;
		1092	}
		1093
1061	#ifndef USE_OBJECT_LIST	1094	#ifndef USE_OBJECT_LIST
1062		1095
		1096	static int
1063	static int hash_fn (const char *key, int table_size);	1097	hash_fn (const char *key, int table_size)
		1098	{
		1099	const unsigned char *p = key;
		1100	uint32_t hash = 2166136261;
		1101
		1102	while (*p)
		1103	hash = (hash ^ *p++) * 16777619;
		1104
		1105	return hash % table_size;
		1106	}
1064		1107
1065	static pointer	1108	static pointer
1066	oblist_initial_value (SCHEME_P)	1109	oblist_initial_value (SCHEME_P)
1067	{	1110	{
1068	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */	1111	return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
…		…
1070		1113
1071	/* returns the new symbol */	1114	/* returns the new symbol */
1072	static pointer	1115	static pointer
1073	oblist_add_by_name (SCHEME_P_ const char *name)	1116	oblist_add_by_name (SCHEME_P_ const char *name)
1074	{	1117	{
1075	int location;	1118	pointer x = generate_symbol (SCHEME_A_ name);
1076
1077	pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1078	set_typeflag (x, T_SYMBOL);
1079	setimmutable (car (x));
1080
1081	location = hash_fn (name, veclength (SCHEME_V->oblist));	1119	int 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)));	1120	vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1083	return x;	1121	return x;
1084	}	1122	}
1085		1123
1086	static INLINE pointer	1124	ecb_inline pointer
1087	oblist_find_by_name (SCHEME_P_ const char *name)	1125	oblist_find_by_name (SCHEME_P_ const char *name)
1088	{	1126	{
1089	int location;	1127	int location;
1090	pointer x;	1128	pointer x;
1091	char *s;	1129	char *s;
1092		1130
1093	location = hash_fn (name, veclength (SCHEME_V->oblist));	1131	location = hash_fn (name, veclength (SCHEME_V->oblist));
1094		1132
1095	for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x))	1133	for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1096	{	1134	{
1097	s = symname (car (x));	1135	s = symname (car (x));
1098		1136
1099	/* case-insensitive, per R5RS section 2 */	1137	/* case-insensitive, per R5RS section 2 */
1100	if (stricmp (name, s) == 0)	1138	if (stricmp (name, s) == 0)
…		…
1110	int i;	1148	int i;
1111	pointer x;	1149	pointer x;
1112	pointer ob_list = NIL;	1150	pointer ob_list = NIL;
1113		1151
1114	for (i = 0; i < veclength (SCHEME_V->oblist); i++)	1152	for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1115	for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x))	1153	for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1116	ob_list = cons (x, ob_list);	1154	ob_list = cons (x, ob_list);
1117		1155
1118	return ob_list;	1156	return ob_list;
1119	}	1157	}
1120		1158
…		…
1124	oblist_initial_value (SCHEME_P)	1162	oblist_initial_value (SCHEME_P)
1125	{	1163	{
1126	return NIL;	1164	return NIL;
1127	}	1165	}
1128		1166
1129	static INLINE pointer	1167	ecb_inline pointer
1130	oblist_find_by_name (SCHEME_P_ const char *name)	1168	oblist_find_by_name (SCHEME_P_ const char *name)
1131	{	1169	{
1132	pointer x;	1170	pointer x;
1133	char *s;	1171	char *s;
1134		1172
…		…
1146		1184
1147	/* returns the new symbol */	1185	/* returns the new symbol */
1148	static pointer	1186	static pointer
1149	oblist_add_by_name (SCHEME_P_ const char *name)	1187	oblist_add_by_name (SCHEME_P_ const char *name)
1150	{	1188	{
1151	pointer x;	1189	pointer x = mk_string (SCHEME_A_ name);
1152
1153	x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1154	set_typeflag (x, T_SYMBOL);	1190	set_typeflag (x, T_SYMBOL);
1155	setimmutable (car (x));	1191	setimmutable (x);
1156	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);	1192	SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1157	return x;	1193	return x;
1158	}	1194	}
1159		1195
1160	static pointer	1196	static pointer
…		…
1193	mk_character (SCHEME_P_ int c)	1229	mk_character (SCHEME_P_ int c)
1194	{	1230	{
1195	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1231	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1196		1232
1197	set_typeflag (x, (T_CHARACTER | T_ATOM));	1233	set_typeflag (x, (T_CHARACTER | T_ATOM));
1198	ivalue_unchecked (x) = c & 0xff;	1234	set_ivalue (x, c & 0xff);
1199	set_num_integer (x);	1235
1200	return x;	1236	return x;
1201	}	1237	}
1202		1238
1203	/* get number atom (integer) */	1239	/* get number atom (integer) */
1204	INTERFACE pointer	1240	INTERFACE pointer
1205	mk_integer (SCHEME_P_ long num)	1241	mk_integer (SCHEME_P_ long n)
1206	{	1242	{
1207	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1243	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1208		1244
1209	set_typeflag (x, (T_NUMBER | T_ATOM));	1245	set_typeflag (x, (T_INTEGER | T_ATOM));
1210	ivalue_unchecked (x) = num;	1246	set_ivalue (x, n);
1211	set_num_integer (x);	1247
1212	return x;	1248	return x;
1213	}	1249	}
1214		1250
1215	INTERFACE pointer	1251	INTERFACE pointer
1216	mk_real (SCHEME_P_ RVALUE n)	1252	mk_real (SCHEME_P_ RVALUE n)
1217	{	1253	{
		1254	#if USE_REAL
1218	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1255	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1219		1256
1220	set_typeflag (x, (T_NUMBER | T_ATOM));	1257	set_typeflag (x, (T_REAL | T_ATOM));
1221	rvalue_unchecked (x) = n;	1258	set_rvalue (x, n);
1222	set_num_real (x);	1259
1223	return x;	1260	return x;
		1261	#else
		1262	return mk_integer (SCHEME_A_ n);
		1263	#endif
1224	}	1264	}
1225		1265
1226	static pointer	1266	static pointer
1227	mk_number (SCHEME_P_ const num n)	1267	mk_number (SCHEME_P_ const num n)
1228	{	1268	{
		1269	#if USE_REAL
1229	if (num_is_fixnum (n))	1270	return num_is_fixnum (n)
		1271	? mk_integer (SCHEME_A_ num_ivalue (n))
		1272	: mk_real (SCHEME_A_ num_rvalue (n));
		1273	#else
1230	return mk_integer (SCHEME_A_ num_get_ivalue (n));	1274	return mk_integer (SCHEME_A_ num_ivalue (n));
1231	else	1275	#endif
1232	return mk_real (SCHEME_A_ num_get_rvalue (n));
1233	}	1276	}
1234		1277
1235	/* allocate name to string area */	1278	/* allocate name to string area */
1236	static char *	1279	static char *
1237	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)	1280	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
…		…
1296	{	1339	{
1297	return get_vector_object (SCHEME_A_ len, NIL);	1340	return get_vector_object (SCHEME_A_ len, NIL);
1298	}	1341	}
1299		1342
1300	INTERFACE void	1343	INTERFACE void
1301	fill_vector (pointer vec, pointer obj)	1344	fill_vector (pointer vec, uint32_t start, pointer obj)
1302	{	1345	{
1303	int i;	1346	int i;
1304		1347
1305	for (i = 0; i < vec->object.vector.length; i++)	1348	for (i = start; i < veclength (vec); i++)
1306	vecvalue (vec)[i] = obj;	1349	vecvalue (vec)[i] = obj;
1307	}	1350	}
1308		1351
1309	INTERFACE pointer	1352	INTERFACE pointer
1310	vector_elem (pointer vec, uint32_t ielem)	1353	vector_get (pointer vec, uint32_t ielem)
1311	{	1354	{
1312	return vecvalue(vec)[ielem];	1355	return vecvalue(vec)[ielem];
1313	}	1356	}
1314		1357
1315	INTERFACE void	1358	INTERFACE void
1316	set_vector_elem (pointer vec, uint32_t ielem, pointer a)	1359	vector_set (pointer vec, uint32_t ielem, pointer a)
1317	{	1360	{
1318	vecvalue(vec)[ielem] = a;	1361	vecvalue(vec)[ielem] = a;
1319	}	1362	}
1320		1363
1321	/* get new symbol */	1364	/* get new symbol */
…		…
1333		1376
1334	INTERFACE pointer	1377	INTERFACE pointer
1335	gensym (SCHEME_P)	1378	gensym (SCHEME_P)
1336	{	1379	{
1337	pointer x;	1380	pointer x;
1338
1339	for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1340	{
1341	char name[40] = "gensym-";	1381	char name[40] = "gensym-";
1342	xnum (name + 7, SCHEME_V->gensym_cnt);	1382	xnum (name + 7, SCHEME_V->gensym_cnt);
1343		1383
1344	/* first check oblist */	1384	return generate_symbol (SCHEME_A_ name);
1345	x = oblist_find_by_name (SCHEME_A_ name);
1346
1347	if (x == NIL)
1348	{
1349	x = oblist_add_by_name (SCHEME_A_ name);
1350	return x;
1351	}
1352	}
1353
1354	return NIL;
1355	}	1385	}
1356		1386
1357	/* make symbol or number atom from string */	1387	/* make symbol or number atom from string */
1358	static pointer	1388	static pointer
1359	mk_atom (SCHEME_P_ char *q)	1389	mk_atom (SCHEME_P_ char *q)
…		…
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	{
…		…
2782	/* () is #t in R5RS */	2812	/* () is #t in R5RS */
2783	#define is_true(p) ((p) != S_F)	2813	#define is_true(p) ((p) != S_F)
2784	#define is_false(p) ((p) == S_F)	2814	#define is_false(p) ((p) == S_F)
2785		2815
2786	/* ========== Environment implementation ========== */	2816	/* ========== Environment implementation ========== */
2787
2788	#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2789
2790	static int
2791	hash_fn (const char *key, int table_size)
2792	{
2793	const unsigned char *p = key;
2794	uint32_t hash = 2166136261;
2795
2796	while (*p)
2797	hash = (hash ^ *p++) * 16777619;
2798
2799	return hash % table_size;
2800	}
2801	#endif
2802		2817
2803	#ifndef USE_ALIST_ENV	2818	#ifndef USE_ALIST_ENV
2804		2819
2805	/*	2820	/*
2806	* In this implementation, each frame of the environment may be	2821	* In this implementation, each frame of the environment may be
…		…
2823		2838
2824	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2839	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2825	setenvironment (SCHEME_V->envir);	2840	setenvironment (SCHEME_V->envir);
2826	}	2841	}
2827		2842
2828	static INLINE void	2843	static uint32_t
		2844	sym_hash (pointer sym, uint32_t size)
		2845	{
		2846	uintptr_t ptr = (uintptr_t)sym;
		2847
		2848	#if 0
		2849	/* table size is prime, so why mix */
		2850	ptr += ptr >> 32;
		2851	ptr += ptr >> 16;
		2852	ptr += ptr >> 8;
		2853	#endif
		2854
		2855	return ptr % size;
		2856	}
		2857
		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 = sym_hash (variable, veclength (car (env)));
2836
2837	set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location)));	2866	vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2838	}	2867	}
2839	else	2868	else
2840	set_car (env, immutable_cons (slot, car (env)));	2869	set_car (env, immutable_cons (slot, car (env)));
2841	}	2870	}
2842		2871
2843	static pointer	2872	static pointer
2844	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)	2873	find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2845	{	2874	{
2846	pointer x, y;	2875	pointer x, y;
2847	int location;
2848		2876
2849	for (x = env; x != NIL; x = cdr (x))	2877	for (x = env; x != NIL; x = cdr (x))
2850	{	2878	{
2851	if (is_vector (car (x)))	2879	if (is_vector (car (x)))
2852	{	2880	{
2853	location = hash_fn (symname (hdl), veclength (car (x)));	2881	int location = sym_hash (hdl, veclength (car (x)));
2854	y = vector_elem (car (x), location);	2882	y = vector_get (car (x), location);
2855	}	2883	}
2856	else	2884	else
2857	y = car (x);	2885	y = car (x);
2858		2886
2859	for (; y != NIL; y = cdr (y))	2887	for (; y != NIL; y = cdr (y))
2860	if (caar (y) == hdl)	2888	if (caar (y) == hdl)
2861	break;	2889	break;
2862		2890
2863	if (y != NIL)	2891	if (y != NIL)
		2892	return car (y);
		2893
		2894	if (!all)
2864	break;	2895	break;
2865
2866	if (!all)
2867	return NIL;
2868	}	2896	}
2869
2870	if (x != NIL)
2871	return car (y);
2872		2897
2873	return NIL;	2898	return NIL;
2874	}	2899	}
2875		2900
2876	#else /* USE_ALIST_ENV */	2901	#else /* USE_ALIST_ENV */
2877		2902
2878	static INLINE void	2903	ecb_inline void
2879	new_frame_in_env (SCHEME_P_ pointer old_env)	2904	new_frame_in_env (SCHEME_P_ pointer old_env)
2880	{	2905	{
2881	SCHEME_V->envir = immutable_cons (NIL, old_env);	2906	SCHEME_V->envir = immutable_cons (NIL, old_env);
2882	setenvironment (SCHEME_V->envir);	2907	setenvironment (SCHEME_V->envir);
2883	}	2908	}
2884		2909
2885	static INLINE void	2910	ecb_inline void
2886	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2911	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2887	{	2912	{
2888	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2913	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2889	}	2914	}
2890		2915
…		…
2898	for (y = car (x); y != NIL; y = cdr (y))	2923	for (y = car (x); y != NIL; y = cdr (y))
2899	if (caar (y) == hdl)	2924	if (caar (y) == hdl)
2900	break;	2925	break;
2901		2926
2902	if (y != NIL)	2927	if (y != NIL)
		2928	return car (y);
2903	break;	2929	break;
2904		2930
2905	if (!all)	2931	if (!all)
2906	return NIL;	2932	break;
2907	}	2933	}
2908
2909	if (x != NIL)
2910	return car (y);
2911		2934
2912	return NIL;	2935	return NIL;
2913	}	2936	}
2914		2937
2915	#endif /* USE_ALIST_ENV else */	2938	#endif /* USE_ALIST_ENV else */
2916		2939
2917	static INLINE void	2940	ecb_inline void
2918	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2941	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2919	{	2942	{
2920	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);	2943	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2921	}	2944	}
2922		2945
2923	static INLINE void	2946	ecb_inline void
2924	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2947	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2925	{	2948	{
2926	set_cdr (slot, value);	2949	set_cdr (slot, value);
2927	}	2950	}
2928		2951
2929	static INLINE pointer	2952	ecb_inline pointer
2930	slot_value_in_env (pointer slot)	2953	slot_value_in_env (pointer slot)
2931	{	2954	{
2932	return cdr (slot);	2955	return cdr (slot);
2933	}	2956	}
2934		2957
…		…
3062	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3085	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3063		3086
3064	return 0;	3087	return 0;
3065	}	3088	}
3066		3089
3067	static INLINE void	3090	ecb_inline void
3068	dump_stack_reset (SCHEME_P)	3091	dump_stack_reset (SCHEME_P)
3069	{	3092	{
3070	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */	3093	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3071	SCHEME_V->dump = (pointer)+0;	3094	SCHEME_V->dump = (pointer)+0;
3072	}	3095	}
3073		3096
3074	static INLINE void	3097	ecb_inline void
3075	dump_stack_initialize (SCHEME_P)	3098	dump_stack_initialize (SCHEME_P)
3076	{	3099	{
3077	SCHEME_V->dump_size = 0;	3100	SCHEME_V->dump_size = 0;
3078	SCHEME_V->dump_base = 0;	3101	SCHEME_V->dump_base = 0;
3079	dump_stack_reset (SCHEME_A);	3102	dump_stack_reset (SCHEME_A);
…		…
3132	int i = 0;	3155	int i = 0;
3133	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3156	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3134		3157
3135	while (cont != NIL)	3158	while (cont != NIL)
3136	{	3159	{
3137	frame->op = ivalue (car (cont)); cont = cdr (cont);	3160	frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont);
3138	frame->args = car (cont) ; cont = cdr (cont);	3161	frame->args = car (cont) ; cont = cdr (cont);
3139	frame->envir = car (cont) ; cont = cdr (cont);	3162	frame->envir = car (cont) ; cont = cdr (cont);
3140	frame->code = car (cont) ; cont = cdr (cont);	3163	frame->code = car (cont) ; cont = cdr (cont);
3141		3164
3142	++frame;	3165	++frame;
3143	++i;	3166	++i;
3144	}	3167	}
3145		3168
3146	SCHEME_V->dump = (pointer)(uintptr_t)i;	3169	SCHEME_V->dump = (pointer)(uintptr_t)i;
3147	}	3170	}
3148		3171
3149	#else	3172	#else
3150		3173
3151	static INLINE void	3174	ecb_inline void
3152	dump_stack_reset (SCHEME_P)	3175	dump_stack_reset (SCHEME_P)
3153	{	3176	{
3154	SCHEME_V->dump = NIL;	3177	SCHEME_V->dump = NIL;
3155	}	3178	}
3156		3179
3157	static INLINE void	3180	ecb_inline void
3158	dump_stack_initialize (SCHEME_P)	3181	dump_stack_initialize (SCHEME_P)
3159	{	3182	{
3160	dump_stack_reset (SCHEME_A);	3183	dump_stack_reset (SCHEME_A);
3161	}	3184	}
3162		3185
…		…
3174	SCHEME_V->value = a;	3197	SCHEME_V->value = a;
3175		3198
3176	if (dump == NIL)	3199	if (dump == NIL)
3177	return -1;	3200	return -1;
3178		3201
3179	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);	3202	SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump);
3180	SCHEME_V->args = car (dump) ; dump = cdr (dump);	3203	SCHEME_V->args = car (dump) ; dump = cdr (dump);
3181	SCHEME_V->envir = car (dump) ; dump = cdr (dump);	3204	SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3182	SCHEME_V->code = car (dump) ; dump = cdr (dump);	3205	SCHEME_V->code = car (dump) ; dump = cdr (dump);
3183		3206
3184	SCHEME_V->dump = dump;	3207	SCHEME_V->dump = dump;
3185		3208
3186	return 0;	3209	return 0;
3187	}	3210	}
…		…
3393		3416
3394	case OP_TRACING:	3417	case OP_TRACING:
3395	{	3418	{
3396	int tr = SCHEME_V->tracing;	3419	int tr = SCHEME_V->tracing;
3397		3420
3398	SCHEME_V->tracing = ivalue (car (args));	3421	SCHEME_V->tracing = ivalue_unchecked (car (args));
3399	s_return (mk_integer (SCHEME_A_ tr));	3422	s_return (mk_integer (SCHEME_A_ tr));
3400	}	3423	}
3401		3424
3402	#endif	3425	#endif
3403		3426
…		…
3912	SCHEME_V->code = car (args);	3935	SCHEME_V->code = car (args);
3913	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);	3936	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3914	s_goto (OP_APPLY);	3937	s_goto (OP_APPLY);
3915	}	3938	}
3916		3939
3917	abort ();	3940	if (USE_ERROR_CHECKING) abort ();
3918	}	3941	}
3919		3942
3920	static int	3943	static int
3921	opexe_1 (SCHEME_P_ enum scheme_opcodes op)	3944	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3922	{	3945	{
3923	pointer args = SCHEME_V->args;	3946	pointer args = SCHEME_V->args;
3924	pointer x = car (args);	3947	pointer x = car (args);
3925	num v;	3948	num v;
3926		3949
3927	#if USE_MATH
3928	RVALUE dd;
3929	#endif
3930
3931	switch (op)	3950	switch (op)
3932	{	3951	{
3933	#if USE_MATH	3952	#if USE_MATH
3934	case OP_INEX2EX: /* inexact->exact */	3953	case OP_INEX2EX: /* inexact->exact */
		3954	{
3935	if (num_is_integer (x))	3955	if (is_integer (x))
3936	s_return (x);	3956	s_return (x);
3937	else if (modf (rvalue_unchecked (x), &dd) == 0)	3957
		3958	RVALUE r = rvalue_unchecked (x);
		3959
		3960	if (r == (RVALUE)(IVALUE)r)
3938	s_return (mk_integer (SCHEME_A_ ivalue (x)));	3961	s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x)));
3939	else	3962	else
3940	Error_1 ("inexact->exact: not integral:", x);	3963	Error_1 ("inexact->exact: not integral:", x);
		3964	}
3941		3965
3942	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));	3966	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))));	3967	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))));	3968	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))));	3969	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
…		…
3963	{	3987	{
3964	RVALUE result;	3988	RVALUE result;
3965	int real_result = 1;	3989	int real_result = 1;
3966	pointer y = cadr (args);	3990	pointer y = cadr (args);
3967		3991
3968	if (num_is_integer (x) && num_is_integer (y))	3992	if (is_integer (x) && is_integer (y))
3969	real_result = 0;	3993	real_result = 0;
3970		3994
3971	/* This 'if' is an R5RS compatibility fix. */	3995	/* This 'if' is an R5RS compatibility fix. */
3972	/* NOTE: Remove this 'if' fix for R6RS. */	3996	/* NOTE: Remove this 'if' fix for R6RS. */
3973	if (rvalue (x) == 0 && rvalue (y) < 0)	3997	if (rvalue (x) == 0 && rvalue (y) < 0)
…		…
3979	/* If the test fails, result is too big for integer. */	4003	/* If the test fails, result is too big for integer. */
3980	if (!real_result)	4004	if (!real_result)
3981	{	4005	{
3982	long result_as_long = result;	4006	long result_as_long = result;
3983		4007
3984	if (result != (RVALUE) result_as_long)	4008	if (result != result_as_long)
3985	real_result = 1;	4009	real_result = 1;
3986	}	4010	}
3987		4011
3988	if (real_result)	4012	if (real_result)
3989	s_return (mk_real (SCHEME_A_ result));	4013	s_return (mk_real (SCHEME_A_ result));
…		…
3994	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));	4018	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))));	4019	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
3996		4020
3997	case OP_TRUNCATE:	4021	case OP_TRUNCATE:
3998	{	4022	{
3999	RVALUE rvalue_of_x;	4023	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)));	4024	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	}	4025	}
4008		4026
4009	case OP_ROUND:	4027	case OP_ROUND:
4010	if (num_is_integer (x))	4028	if (is_integer (x))
4011	s_return (x);	4029	s_return (x);
4012		4030
4013	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));	4031	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4014	#endif	4032	#endif
4015		4033
4016	case OP_ADD: /* + */	4034	case OP_ADD: /* + */
4017	v = num_zero;	4035	v = num_zero;
4018		4036
4019	for (x = args; x != NIL; x = cdr (x))	4037	for (x = args; x != NIL; x = cdr (x))
4020	v = num_op ('+', v, nvalue (car (x)));	4038	v = num_op (NUM_ADD, v, nvalue (car (x)));
4021		4039
4022	s_return (mk_number (SCHEME_A_ v));	4040	s_return (mk_number (SCHEME_A_ v));
4023		4041
4024	case OP_MUL: /* * */	4042	case OP_MUL: /* * */
4025	v = num_one;	4043	v = num_one;
4026		4044
4027	for (x = args; x != NIL; x = cdr (x))	4045	for (x = args; x != NIL; x = cdr (x))
4028	v = num_op ('*', v, nvalue (car (x)));	4046	v = num_op (NUM_MUL, v, nvalue (car (x)));
4029		4047
4030	s_return (mk_number (SCHEME_A_ v));	4048	s_return (mk_number (SCHEME_A_ v));
4031		4049
4032	case OP_SUB: /* - */	4050	case OP_SUB: /* - */
4033	if (cdr (args) == NIL)	4051	if (cdr (args) == NIL)
…		…
4040	x = cdr (args);	4058	x = cdr (args);
4041	v = nvalue (car (args));	4059	v = nvalue (car (args));
4042	}	4060	}
4043		4061
4044	for (; x != NIL; x = cdr (x))	4062	for (; x != NIL; x = cdr (x))
4045	v = num_op ('-', v, nvalue (car (x)));	4063	v = num_op (NUM_SUB, v, nvalue (car (x)));
4046		4064
4047	s_return (mk_number (SCHEME_A_ v));	4065	s_return (mk_number (SCHEME_A_ v));
4048		4066
4049	case OP_DIV: /* / */	4067	case OP_DIV: /* / */
4050	if (cdr (args) == NIL)	4068	if (cdr (args) == NIL)
…		…
4057	x = cdr (args);	4075	x = cdr (args);
4058	v = nvalue (car (args));	4076	v = nvalue (car (args));
4059	}	4077	}
4060		4078
4061	for (; x != NIL; x = cdr (x))	4079	for (; x != NIL; x = cdr (x))
4062	{
4063	if (!is_zero_rvalue (rvalue (car (x))))	4080	if (!is_zero_rvalue (rvalue (car (x))))
4064	v = num_div (v, nvalue (car (x)));	4081	v = num_div (v, nvalue (car (x)));
4065	else	4082	else
4066	Error_0 ("/: division by zero");	4083	Error_0 ("/: division by zero");
4067	}
4068		4084
4069	s_return (mk_number (SCHEME_A_ v));	4085	s_return (mk_number (SCHEME_A_ v));
4070		4086
4071	case OP_INTDIV: /* quotient */	4087	case OP_INTDIV: /* quotient */
4072	if (cdr (args) == NIL)	4088	if (cdr (args) == NIL)
…		…
4081	}	4097	}
4082		4098
4083	for (; x != NIL; x = cdr (x))	4099	for (; x != NIL; x = cdr (x))
4084	{	4100	{
4085	if (ivalue (car (x)) != 0)	4101	if (ivalue (car (x)) != 0)
4086	v = num_op ('/', v, nvalue (car (x)));	4102	v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4087	else	4103	else
4088	Error_0 ("quotient: division by zero");	4104	Error_0 ("quotient: division by zero");
4089	}	4105	}
4090		4106
4091	s_return (mk_number (SCHEME_A_ v));	4107	s_return (mk_number (SCHEME_A_ v));
…		…
4137	}	4153	}
4138	else	4154	else
4139	Error_0 ("set-cdr!: unable to alter immutable pair");	4155	Error_0 ("set-cdr!: unable to alter immutable pair");
4140		4156
4141	case OP_CHAR2INT: /* char->integer */	4157	case OP_CHAR2INT: /* char->integer */
4142	s_return (mk_integer (SCHEME_A_ ivalue (x)));	4158	s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x)));
4143		4159
4144	case OP_INT2CHAR: /* integer->char */	4160	case OP_INT2CHAR: /* integer->char */
4145	s_return (mk_character (SCHEME_A_ ivalue (x)));	4161	s_return (mk_character (SCHEME_A_ ivalue_unchecked (x)));
4146		4162
4147	case OP_CHARUPCASE:	4163	case OP_CHARUPCASE:
4148	{	4164	{
4149	unsigned char c = ivalue (x);	4165	unsigned char c = ivalue_unchecked (x);
4150	c = toupper (c);	4166	c = toupper (c);
4151	s_return (mk_character (SCHEME_A_ c));	4167	s_return (mk_character (SCHEME_A_ c));
4152	}	4168	}
4153		4169
4154	case OP_CHARDNCASE:	4170	case OP_CHARDNCASE:
4155	{	4171	{
4156	unsigned char c = ivalue (x);	4172	unsigned char c = ivalue_unchecked (x);
4157	c = tolower (c);	4173	c = tolower (c);
4158	s_return (mk_character (SCHEME_A_ c));	4174	s_return (mk_character (SCHEME_A_ c));
4159	}	4175	}
4160		4176
4161	case OP_STR2SYM: /* string->symbol */	4177	case OP_STR2SYM: /* string->symbol */
…		…
4238	Error_1 ("atom->string: not an atom:", x);	4254	Error_1 ("atom->string: not an atom:", x);
4239	}	4255	}
4240		4256
4241	case OP_MKSTRING: /* make-string */	4257	case OP_MKSTRING: /* make-string */
4242	{	4258	{
4243	int fill = ' ';	4259	int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' ';
4244	int len;
4245
4246	len = ivalue (x);	4260	int len = ivalue_unchecked (x);
4247
4248	if (cdr (args) != NIL)
4249	fill = charvalue (cadr (args));
4250		4261
4251	s_return (mk_empty_string (SCHEME_A_ len, fill));	4262	s_return (mk_empty_string (SCHEME_A_ len, fill));
4252	}	4263	}
4253		4264
4254	case OP_STRLEN: /* string-length */	4265	case OP_STRLEN: /* string-length */
4255	s_return (mk_integer (SCHEME_A_ strlength (x)));	4266	s_return (mk_integer (SCHEME_A_ strlength (x)));
4256		4267
4257	case OP_STRREF: /* string-ref */	4268	case OP_STRREF: /* string-ref */
4258	{	4269	{
4259	char *str;
4260	int index;
4261
4262	str = strvalue (x);	4270	char *str = strvalue (x);
4263
4264	index = ivalue (cadr (args));	4271	int index = ivalue_unchecked (cadr (args));
4265		4272
4266	if (index >= strlength (x))	4273	if (index >= strlength (x))
4267	Error_1 ("string-ref: out of bounds:", cadr (args));	4274	Error_1 ("string-ref: out of bounds:", cadr (args));
4268		4275
4269	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));	4276	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4270	}	4277	}
4271		4278
4272	case OP_STRSET: /* string-set! */	4279	case OP_STRSET: /* string-set! */
4273	{	4280	{
4274	char *str;	4281	char *str = strvalue (x);
4275	int index;	4282	int index = ivalue_unchecked (cadr (args));
4276	int c;	4283	int c;
4277		4284
4278	if (is_immutable (x))	4285	if (is_immutable (x))
4279	Error_1 ("string-set!: unable to alter immutable string:", x);	4286	Error_1 ("string-set!: unable to alter immutable string:", x);
4280
4281	str = strvalue (x);
4282
4283	index = ivalue (cadr (args));
4284		4287
4285	if (index >= strlength (x))	4288	if (index >= strlength (x))
4286	Error_1 ("string-set!: out of bounds:", cadr (args));	4289	Error_1 ("string-set!: out of bounds:", cadr (args));
4287		4290
4288	c = charvalue (caddr (args));	4291	c = charvalue (caddr (args));
…		…
4311	s_return (newstr);	4314	s_return (newstr);
4312	}	4315	}
4313		4316
4314	case OP_SUBSTR: /* substring */	4317	case OP_SUBSTR: /* substring */
4315	{	4318	{
4316	char *str;	4319	char *str = strvalue (x);
4317	int index0;	4320	int index0 = ivalue_unchecked (cadr (args));
4318	int index1;	4321	int index1;
4319	int len;	4322	int len;
4320		4323
4321	str = strvalue (x);
4322
4323	index0 = ivalue (cadr (args));
4324
4325	if (index0 > strlength (x))	4324	if (index0 > strlength (x))
4326	Error_1 ("substring: start out of bounds:", cadr (args));	4325	Error_1 ("substring: start out of bounds:", cadr (args));
4327		4326
4328	if (cddr (args) != NIL)	4327	if (cddr (args) != NIL)
4329	{	4328	{
4330	index1 = ivalue (caddr (args));	4329	index1 = ivalue_unchecked (caddr (args));
4331		4330
4332	if (index1 > strlength (x) || index1 < index0)	4331	if (index1 > strlength (x) || index1 < index0)
4333	Error_1 ("substring: end out of bounds:", caddr (args));	4332	Error_1 ("substring: end out of bounds:", caddr (args));
4334	}	4333	}
4335	else	4334	else
…		…
4358	if (SCHEME_V->no_memory)	4357	if (SCHEME_V->no_memory)
4359	s_return (S_SINK);	4358	s_return (S_SINK);
4360	#endif	4359	#endif
4361		4360
4362	for (x = args, i = 0; is_pair (x); x = cdr (x), i++)	4361	for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4363	set_vector_elem (vec, i, car (x));	4362	vector_set (vec, i, car (x));
4364		4363
4365	s_return (vec);	4364	s_return (vec);
4366	}	4365	}
4367		4366
4368	case OP_MKVECTOR: /* make-vector */	4367	case OP_MKVECTOR: /* make-vector */
4369	{	4368	{
4370	pointer fill = NIL;	4369	pointer fill = NIL;
4371	int len;
4372	pointer vec;	4370	pointer vec;
4373
4374	len = ivalue (x);	4371	int len = ivalue_unchecked (x);
4375		4372
4376	if (cdr (args) != NIL)	4373	if (cdr (args) != NIL)
4377	fill = cadr (args);	4374	fill = cadr (args);
4378		4375
4379	vec = mk_vector (SCHEME_A_ len);	4376	vec = mk_vector (SCHEME_A_ len);
…		…
4382	if (SCHEME_V->no_memory)	4379	if (SCHEME_V->no_memory)
4383	s_return (S_SINK);	4380	s_return (S_SINK);
4384	#endif	4381	#endif
4385		4382
4386	if (fill != NIL)	4383	if (fill != NIL)
4387	fill_vector (vec, fill);	4384	fill_vector (vec, 0, fill);
4388		4385
4389	s_return (vec);	4386	s_return (vec);
4390	}	4387	}
4391		4388
4392	case OP_VECLEN: /* vector-length */	4389	case OP_VECLEN: /* vector-length */
4393	s_return (mk_integer (SCHEME_A_ veclength (x)));	4390	s_return (mk_integer (SCHEME_A_ veclength (x)));
4394		4391
4395	case OP_VECREF: /* vector-ref */	4392	case OP_VECREF: /* vector-ref */
4396	{	4393	{
4397	int index;
4398
4399	index = ivalue (cadr (args));	4394	int index = ivalue_unchecked (cadr (args));
4400		4395
4401	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)	4396	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4402	Error_1 ("vector-ref: out of bounds:", cadr (args));	4397	Error_1 ("vector-ref: out of bounds:", cadr (args));
4403		4398
4404	s_return (vector_elem (x, index));	4399	s_return (vector_get (x, index));
4405	}	4400	}
4406		4401
4407	case OP_VECSET: /* vector-set! */	4402	case OP_VECSET: /* vector-set! */
4408	{	4403	{
4409	int index;	4404	int index = ivalue_unchecked (cadr (args));
4410		4405
4411	if (is_immutable (x))	4406	if (is_immutable (x))
4412	Error_1 ("vector-set!: unable to alter immutable vector:", x);	4407	Error_1 ("vector-set!: unable to alter immutable vector:", x);
4413		4408
4414	index = ivalue (cadr (args));
4415
4416	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)	4409	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4417	Error_1 ("vector-set!: out of bounds:", cadr (args));	4410	Error_1 ("vector-set!: out of bounds:", cadr (args));
4418		4411
4419	set_vector_elem (x, index, caddr (args));	4412	vector_set (x, index, caddr (args));
4420	s_return (x);	4413	s_return (x);
4421	}	4414	}
4422	}	4415	}
4423		4416
4424	abort ();	4417	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	}	4418	}
4480		4419
4481	static int	4420	static int
4482	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	4421	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4483	{	4422	{
…		…
4529	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;	4468	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4530	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */	4469	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4531	case OP_CHARP: /* char? */ r = is_character (a) ; break;	4470	case OP_CHARP: /* char? */ r = is_character (a) ; break;
4532		4471
4533	#if USE_CHAR_CLASSIFIERS	4472	#if USE_CHAR_CLASSIFIERS
4534	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue (a)); break;	4473	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4535	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue (a)); break;	4474	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4536	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue (a)); break;	4475	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
4537	case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue (a)); break;	4476	case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break;
4538	case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue (a)); break;	4477	case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break;
4539	#endif	4478	#endif
4540		4479
4541	#if USE_PORTS	4480	#if USE_PORTS
4542	case OP_PORTP: /* port? */ r = is_port (a) ; break;	4481	case OP_PORTP: /* port? */ r = is_port (a) ; break;
4543	case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;	4482	case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
…		…
4744		4683
4745	case OP_NEWSEGMENT: /* new-segment */	4684	case OP_NEWSEGMENT: /* new-segment */
4746	if (!is_pair (args) || !is_number (a))	4685	if (!is_pair (args) || !is_number (a))
4747	Error_0 ("new-segment: argument must be a number");	4686	Error_0 ("new-segment: argument must be a number");
4748		4687
4749	alloc_cellseg (SCHEME_A_ (int)ivalue (a));	4688	alloc_cellseg (SCHEME_A_ ivalue (a));
4750		4689
4751	s_return (S_T);	4690	s_return (S_T);
4752		4691
4753	case OP_OBLIST: /* oblist */	4692	case OP_OBLIST: /* oblist */
4754	s_return (oblist_all_symbols (SCHEME_A));	4693	s_return (oblist_all_symbols (SCHEME_A));
…		…
4783	break;	4722	break;
4784	}	4723	}
4785		4724
4786	p = port_from_filename (SCHEME_A_ strvalue (a), prop);	4725	p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4787		4726
4788	if (p == NIL)	4727	s_return (p == NIL ? S_F : p);
4789	s_return (S_F);
4790
4791	s_return (p);
4792	}	4728	}
4793		4729
4794	# if USE_STRING_PORTS	4730	# if USE_STRING_PORTS
4795		4731
4796	case OP_OPEN_INSTRING: /* open-input-string */	4732	case OP_OPEN_INSTRING: /* open-input-string */
…		…
4811	}	4747	}
4812		4748
4813	p = port_from_string (SCHEME_A_ strvalue (a),	4749	p = port_from_string (SCHEME_A_ strvalue (a),
4814	strvalue (a) + strlength (a), prop);	4750	strvalue (a) + strlength (a), prop);
4815		4751
4816	if (p == NIL)	4752	s_return (p == NIL ? S_F : p);
4817	s_return (S_F);
4818
4819	s_return (p);
4820	}	4753	}
4821		4754
4822	case OP_OPEN_OUTSTRING: /* open-output-string */	4755	case OP_OPEN_OUTSTRING: /* open-output-string */
4823	{	4756	{
4824	pointer p;	4757	pointer p;
4825		4758
4826	if (a == NIL)	4759	if (a == NIL)
4827	{
4828	p = port_from_scratch (SCHEME_A);	4760	p = port_from_scratch (SCHEME_A);
4829
4830	if (p == NIL)
4831	s_return (S_F);
4832	}
4833	else	4761	else
4834	{
4835	p = port_from_string (SCHEME_A_ strvalue (a),	4762	p = port_from_string (SCHEME_A_ strvalue (a),
4836	strvalue (a) + strlength (a), port_output);	4763	strvalue (a) + strlength (a), port_output);
4837		4764
4838	if (p == NIL)	4765	s_return (p == NIL ? S_F : p);
4839	s_return (S_F);
4840	}
4841
4842	s_return (p);
4843	}	4766	}
4844		4767
4845	case OP_GET_OUTSTRING: /* get-output-string */	4768	case OP_GET_OUTSTRING: /* get-output-string */
4846	{	4769	{
4847	port *p;	4770	port *p;
…		…
4886	case OP_CURR_ENV: /* current-environment */	4809	case OP_CURR_ENV: /* current-environment */
4887	s_return (SCHEME_V->envir);	4810	s_return (SCHEME_V->envir);
4888		4811
4889	}	4812	}
4890		4813
4891	abort ();	4814	if (USE_ERROR_CHECKING) abort ();
4892	}	4815	}
4893		4816
4894	static int	4817	static int
4895	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4818	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4896	{	4819	{
…		…
5215	putstr (SCHEME_A_ ")");	5138	putstr (SCHEME_A_ ")");
5216	s_return (S_T);	5139	s_return (S_T);
5217	}	5140	}
5218	else	5141	else
5219	{	5142	{
5220	pointer elem = vector_elem (vec, i);	5143	pointer elem = vector_get (vec, i);
5221		5144
5222	ivalue_unchecked (cdr (args)) = i + 1;	5145	ivalue_unchecked (cdr (args)) = i + 1;
5223	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);	5146	s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5224	SCHEME_V->args = elem;	5147	SCHEME_V->args = elem;
5225		5148
…		…
5229	s_goto (OP_P0LIST);	5152	s_goto (OP_P0LIST);
5230	}	5153	}
5231	}	5154	}
5232	}	5155	}
5233		5156
5234	abort ();	5157	if (USE_ERROR_CHECKING) abort ();
5235	}	5158	}
5236		5159
5237	static int	5160	static int
5238	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5161	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5239	{	5162	{
…		…
5292		5215
5293	case OP_MACROP: /* macro? */	5216	case OP_MACROP: /* macro? */
5294	s_retbool (is_macro (a));	5217	s_retbool (is_macro (a));
5295	}	5218	}
5296		5219
5297	abort ();	5220	if (USE_ERROR_CHECKING) abort ();
5298	}	5221	}
5299		5222
5300	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */	5223	/* 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);	5224	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5302		5225
5303	typedef int (*test_predicate)(pointer);	5226	typedef int (*test_predicate)(pointer);
5304	static int	5227	static int
5305	is_any (pointer p)	5228	tst_any (pointer p)
5306	{	5229	{
5307	return 1;	5230	return 1;
5308	}	5231	}
5309		5232
5310	static int	5233	static int
5311	is_nonneg (pointer p)	5234	tst_inonneg (pointer p)
5312	{	5235	{
5313	return ivalue (p) >= 0 && is_integer (p);	5236	return is_integer (p) && ivalue_unchecked (p) >= 0;
5314	}	5237	}
5315		5238
5316	static int	5239	static int
5317	tst_is_list (pointer p)	5240	tst_is_list (SCHEME_P_ pointer p)
5318	{	5241	{
5319	return p == NIL || is_pair (p);	5242	return p == NIL || is_pair (p);
5320	}	5243	}
5321		5244
5322	/* Correspond carefully with following defines! */	5245	/* Correspond carefully with following defines! */
5323	static struct	5246	static struct
5324	{	5247	{
5325	test_predicate fct;	5248	test_predicate fct;
5326	const char *kind;	5249	const char *kind;
5327	} tests[] =	5250	} tests[] = {
5328	{
5329	{ is_any, 0 },	5251	{ tst_any , 0 },
5330	{ is_string, "string" },	5252	{ is_string , "string" },
5331	{ is_symbol, "symbol" },	5253	{ is_symbol , "symbol" },
5332	{ is_port, "port" },	5254	{ is_port , "port" },
5333	{ is_inport, "input port" },	5255	{ is_inport , "input port" },
5334	{ is_outport, "output port" },	5256	{ is_outport , "output port" },
5335	{ is_environment, "environment" },	5257	{ is_environment, "environment" },
5336	{ is_pair, "pair" },	5258	{ is_pair , "pair" },
5337	{ tst_is_list, "pair or '()" },	5259	{ 0 , "pair or '()" },
5338	{ is_character, "character" },	5260	{ is_character , "character" },
5339	{ is_vector, "vector" },	5261	{ is_vector , "vector" },
5340	{ is_number, "number" },	5262	{ is_number , "number" },
5341	{ is_integer, "integer" },	5263	{ is_integer , "integer" },
5342	{ is_nonneg, "non-negative integer" }	5264	{ tst_inonneg , "non-negative integer" }
5343	};	5265	};
5344		5266
5345	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */	5267	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5346	#define TST_ANY "\001"	5268	#define TST_ANY "\001"
5347	#define TST_STRING "\002"	5269	#define TST_STRING "\002"
…		…
5388	typedef struct	5310	typedef struct
5389	{	5311	{
5390	uint8_t func;	5312	uint8_t func;
5391	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */	5313	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
5392	uint8_t builtin;	5314	uint8_t builtin;
		5315	#if USE_ERROR_CHECKING
5393	uint8_t min_arity;	5316	uint8_t min_arity;
5394	uint8_t max_arity;	5317	uint8_t max_arity;
5395	char arg_tests_encoding[3];	5318	char arg_tests_encoding[3];
		5319	#endif
5396	} op_code_info;	5320	} op_code_info;
5397		5321
5398	static const op_code_info dispatch_table[] = {	5322	static const op_code_info dispatch_table[] = {
		5323	#if USE_ERROR_CHECKING
5399	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },	5324	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
		5325	#else
		5326	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 },
		5327	#endif
5400	#include "opdefines.h"	5328	#include "opdefines.h"
5401	#undef OP_DEF	5329	#undef OP_DEF
5402	{0}	5330	{0}
5403	};	5331	};
5404		5332
5405	/* kernel of this interpreter */	5333	/* kernel of this interpreter */
5406	static void	5334	static void ecb_hot
5407	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5335	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5408	{	5336	{
5409	SCHEME_V->op = op;	5337	SCHEME_V->op = op;
5410		5338
5411	for (;;)	5339	for (;;)
…		…
5446	{	5374	{
5447	pointer arg = car (arglist);	5375	pointer arg = car (arglist);
5448		5376
5449	j = t[0];	5377	j = t[0];
5450		5378
		5379	/*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */
		5380	if (j == TST_LIST[0])
		5381	{
		5382	if (!tst_is_list (SCHEME_A_ arg))
		5383	break;
		5384	}
		5385	else
		5386	{
5451	if (!tests[j - 1].fct (arg))	5387	if (!tests[j - 1].fct (arg))
5452	break;	5388	break;
		5389	}
5453		5390
5454	if (t[1]) /* last test is replicated as necessary */	5391	if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */
5455	t++;	5392	t++;
5456		5393
5457	arglist = cdr (arglist);	5394	arglist = cdr (arglist);
5458	i++;	5395	i++;
5459	}	5396	}
…		…
5514	mk_proc (SCHEME_P_ enum scheme_opcodes op)	5451	mk_proc (SCHEME_P_ enum scheme_opcodes op)
5515	{	5452	{
5516	pointer y = get_cell (SCHEME_A_ NIL, NIL);	5453	pointer y = get_cell (SCHEME_A_ NIL, NIL);
5517	set_typeflag (y, (T_PROC | T_ATOM));	5454	set_typeflag (y, (T_PROC | T_ATOM));
5518	ivalue_unchecked (y) = op;	5455	ivalue_unchecked (y) = op;
5519	set_num_integer (y);
5520	return y;	5456	return y;
5521	}	5457	}
5522		5458
5523	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */	5459	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5524	static int	5460	static int
…		…
5589	return OP_C0STREAM; /* cons-stream */	5525	return OP_C0STREAM; /* cons-stream */
5590	}	5526	}
5591	}	5527	}
5592		5528
5593	#if USE_MULTIPLICITY	5529	#if USE_MULTIPLICITY
5594	scheme *	5530	ecb_cold scheme *
5595	scheme_init_new ()	5531	scheme_init_new ()
5596	{	5532	{
5597	scheme *sc = malloc (sizeof (scheme));	5533	scheme *sc = malloc (sizeof (scheme));
5598		5534
5599	if (!scheme_init (SCHEME_A))	5535	if (!scheme_init (SCHEME_A))
…		…
5604	else	5540	else
5605	return sc;	5541	return sc;
5606	}	5542	}
5607	#endif	5543	#endif
5608		5544
5609	int	5545	ecb_cold int
5610	scheme_init (SCHEME_P)	5546	scheme_init (SCHEME_P)
5611	{	5547	{
5612	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	5548	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5613	pointer x;	5549	pointer x;
5614		5550
…		…
5739	scheme_set_external_data (SCHEME_P_ void *p)	5675	scheme_set_external_data (SCHEME_P_ void *p)
5740	{	5676	{
5741	SCHEME_V->ext_data = p;	5677	SCHEME_V->ext_data = p;
5742	}	5678	}
5743		5679
5744	void	5680	ecb_cold void
5745	scheme_deinit (SCHEME_P)	5681	scheme_deinit (SCHEME_P)
5746	{	5682	{
5747	int i;	5683	int i;
5748		5684
5749	#if SHOW_ERROR_LINE	5685	#if SHOW_ERROR_LINE

Diff Legend

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