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.26 by root, Sat Nov 28 05:12:53 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
…		…
267	vector_length (pointer vec)	281	vector_length (pointer vec)
268	{	282	{
269	return vec->object.vector.length;	283	return vec->object.vector.length;
270	}	284	}
271		285
272	INTERFACE INLINE int	286	INTERFACE int
		287	is_integer (pointer p)
		288	{
		289	return type (p) == T_INTEGER;
		290	}
		291
		292	/* not the same as in scheme, where integers are (correctly :) reals */
		293	INTERFACE int
		294	is_real (pointer p)
		295	{
		296	return type (p) == T_REAL;
		297	}
		298
		299	INTERFACE int
273	is_number (pointer p)	300	is_number (pointer p)
274	{	301	{
275	return type (p) == T_NUMBER;	302	return is_integer (p) || is_real (p);
276	}	303	}
277		304
278	INTERFACE INLINE int	305	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)	306	is_character (pointer p)
298	{	307	{
299	return type (p) == T_CHARACTER;	308	return type (p) == T_CHARACTER;
300	}	309	}
301		310
302	INTERFACE INLINE char *	311	INTERFACE char *
303	string_value (pointer p)	312	string_value (pointer p)
304	{	313	{
305	return strvalue (p);	314	return strvalue (p);
306	}	315	}
307		316
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)	317	#define ivalue_unchecked(p) (p)->object.ivalue
		318	#define set_ivalue(p,v) (p)->object.ivalue = (v)
		319
339	#if USE_REAL	320	#if USE_REAL
340	# define rvalue_unchecked(p) ((p)->object.number.value.rvalue)	321	#define rvalue_unchecked(p) (p)->object.rvalue
341	# define set_num_integer(p) (p)->object.number.is_fixnum=1;	322	#define set_rvalue(p,v) (p)->object.rvalue = (v)
342	# define set_num_real(p) (p)->object.number.is_fixnum=0;
343	#else	323	#else
344	# define rvalue_unchecked(p) ((p)->object.number.value.ivalue)	324	#define rvalue_unchecked(p) (p)->object.ivalue
345	# define set_num_integer(p) 0	325	#define set_rvalue(p,v) (p)->object.ivalue = (v)
346	# define set_num_real(p) 0
347	#endif	326	#endif
		327
348	INTERFACE long	328	INTERFACE long
349	charvalue (pointer p)	329	charvalue (pointer p)
350	{	330	{
351	return ivalue_unchecked (p);	331	return ivalue_unchecked (p);
352	}	332	}
353		333
354	INTERFACE INLINE int	334	INTERFACE int
355	is_port (pointer p)	335	is_port (pointer p)
356	{	336	{
357	return type (p) == T_PORT;	337	return type (p) == T_PORT;
358	}	338	}
359		339
360	INTERFACE INLINE int	340	INTERFACE int
361	is_inport (pointer p)	341	is_inport (pointer p)
362	{	342	{
363	return is_port (p) && p->object.port->kind & port_input;	343	return is_port (p) && p->object.port->kind & port_input;
364	}	344	}
365		345
366	INTERFACE INLINE int	346	INTERFACE int
367	is_outport (pointer p)	347	is_outport (pointer p)
368	{	348	{
369	return is_port (p) && p->object.port->kind & port_output;	349	return is_port (p) && p->object.port->kind & port_output;
370	}	350	}
371		351
372	INTERFACE INLINE int	352	INTERFACE int
373	is_pair (pointer p)	353	is_pair (pointer p)
374	{	354	{
375	return type (p) == T_PAIR;	355	return type (p) == T_PAIR;
376	}	356	}
377		357
…		…
409	pair_cdr (pointer p)	389	pair_cdr (pointer p)
410	{	390	{
411	return cdr (p);	391	return cdr (p);
412	}	392	}
413		393
414	INTERFACE INLINE int	394	INTERFACE int
415	is_symbol (pointer p)	395	is_symbol (pointer p)
416	{	396	{
417	return type (p) == T_SYMBOL;	397	return type (p) == T_SYMBOL;
418	}	398	}
419		399
420	INTERFACE INLINE char *	400	INTERFACE char *
421	symname (pointer p)	401	symname (pointer p)
422	{	402	{
423	return strvalue (car (p));	403	return strvalue (car (p));
424	}	404	}
425		405
426	#if USE_PLIST	406	#if USE_PLIST
427	SCHEME_EXPORT INLINE int	407	SCHEME_EXPORT int
428	hasprop (pointer p)	408	hasprop (pointer p)
429	{	409	{
430	return typeflag (p) & T_SYMBOL;	410	return typeflag (p) & T_SYMBOL;
431	}	411	}
432		412
433	# define symprop(p) cdr(p)	413	# define symprop(p) cdr(p)
434	#endif	414	#endif
435		415
436	INTERFACE INLINE int	416	INTERFACE int
437	is_syntax (pointer p)	417	is_syntax (pointer p)
438	{	418	{
439	return typeflag (p) & T_SYNTAX;	419	return typeflag (p) & T_SYNTAX;
440	}	420	}
441		421
442	INTERFACE INLINE int	422	INTERFACE int
443	is_proc (pointer p)	423	is_proc (pointer p)
444	{	424	{
445	return type (p) == T_PROC;	425	return type (p) == T_PROC;
446	}	426	}
447		427
448	INTERFACE INLINE int	428	INTERFACE int
449	is_foreign (pointer p)	429	is_foreign (pointer p)
450	{	430	{
451	return type (p) == T_FOREIGN;	431	return type (p) == T_FOREIGN;
452	}	432	}
453		433
454	INTERFACE INLINE char *	434	INTERFACE char *
455	syntaxname (pointer p)	435	syntaxname (pointer p)
456	{	436	{
457	return strvalue (car (p));	437	return strvalue (car (p));
458	}	438	}
459		439
460	#define procnum(p) ivalue (p)	440	#define procnum(p) ivalue_unchecked (p)
461	static const char *procname (pointer x);	441	static const char *procname (pointer x);
462		442
463	INTERFACE INLINE int	443	INTERFACE int
464	is_closure (pointer p)	444	is_closure (pointer p)
465	{	445	{
466	return type (p) == T_CLOSURE;	446	return type (p) == T_CLOSURE;
467	}	447	}
468		448
469	INTERFACE INLINE int	449	INTERFACE int
470	is_macro (pointer p)	450	is_macro (pointer p)
471	{	451	{
472	return type (p) == T_MACRO;	452	return type (p) == T_MACRO;
473	}	453	}
474		454
475	INTERFACE INLINE pointer	455	INTERFACE pointer
476	closure_code (pointer p)	456	closure_code (pointer p)
477	{	457	{
478	return car (p);	458	return car (p);
479	}	459	}
480		460
481	INTERFACE INLINE pointer	461	INTERFACE pointer
482	closure_env (pointer p)	462	closure_env (pointer p)
483	{	463	{
484	return cdr (p);	464	return cdr (p);
485	}	465	}
486		466
487	INTERFACE INLINE int	467	INTERFACE int
488	is_continuation (pointer p)	468	is_continuation (pointer p)
489	{	469	{
490	return type (p) == T_CONTINUATION;	470	return type (p) == T_CONTINUATION;
491	}	471	}
492		472
493	#define cont_dump(p) cdr (p)	473	#define cont_dump(p) cdr (p)
494	#define set_cont_dump(p,v) set_cdr ((p), (v))	474	#define set_cont_dump(p,v) set_cdr ((p), (v))
495		475
496	/* To do: promise should be forced ONCE only */	476	/* To do: promise should be forced ONCE only */
497	INTERFACE INLINE int	477	INTERFACE int
498	is_promise (pointer p)	478	is_promise (pointer p)
499	{	479	{
500	return type (p) == T_PROMISE;	480	return type (p) == T_PROMISE;
501	}	481	}
502		482
503	INTERFACE INLINE int	483	INTERFACE int
504	is_environment (pointer p)	484	is_environment (pointer p)
505	{	485	{
506	return type (p) == T_ENVIRONMENT;	486	return type (p) == T_ENVIRONMENT;
507	}	487	}
508		488
…		…
514		494
515	#define is_mark(p) (typeflag (p) & T_MARK)	495	#define is_mark(p) (typeflag (p) & T_MARK)
516	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)	496	#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
517	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)	497	#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
518		498
519	INTERFACE INLINE int	499	INTERFACE int
520	is_immutable (pointer p)	500	is_immutable (pointer p)
521	{	501	{
522	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;	502	return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
523	}	503	}
524		504
525	INTERFACE INLINE void	505	INTERFACE void
526	setimmutable (pointer p)	506	setimmutable (pointer p)
527	{	507	{
528	#if USE_ERROR_CHECKING	508	#if USE_ERROR_CHECKING
529	set_typeflag (p, typeflag (p) | T_IMMUTABLE);	509	set_typeflag (p, typeflag (p) | T_IMMUTABLE);
530	#endif	510	#endif
531	}	511	}
532		512
		513	/* Result is:
		514	proper list: length
		515	circular list: -1
		516	not even a pair: -2
		517	dotted list: -2 minus length before dot
		518	*/
		519	INTERFACE int
		520	list_length (SCHEME_P_ pointer a)
		521	{
		522	int i = 0;
		523	pointer slow, fast;
		524
		525	slow = fast = a;
		526
		527	while (1)
		528	{
		529	if (fast == NIL)
		530	return i;
		531
		532	if (!is_pair (fast))
		533	return -2 - i;
		534
		535	fast = cdr (fast);
		536	++i;
		537
		538	if (fast == NIL)
		539	return i;
		540
		541	if (!is_pair (fast))
		542	return -2 - i;
		543
		544	++i;
		545	fast = cdr (fast);
		546
		547	/* Safe because we would have already returned if `fast'
		548	encountered a non-pair. */
		549	slow = cdr (slow);
		550
		551	if (fast == slow)
		552	{
		553	/* the fast pointer has looped back around and caught up
		554	with the slow pointer, hence the structure is circular,
		555	not of finite length, and therefore not a list */
		556	return -1;
		557	}
		558	}
		559	}
		560
		561	INTERFACE int
		562	is_list (SCHEME_P_ pointer a)
		563	{
		564	return list_length (SCHEME_A_ a) >= 0;
		565	}
		566
533	#if USE_CHAR_CLASSIFIERS	567	#if USE_CHAR_CLASSIFIERS
534	static INLINE int	568	ecb_inline int
535	Cisalpha (int c)	569	Cisalpha (int c)
536	{	570	{
537	return isascii (c) && isalpha (c);	571	return isascii (c) && isalpha (c);
538	}	572	}
539		573
540	static INLINE int	574	ecb_inline int
541	Cisdigit (int c)	575	Cisdigit (int c)
542	{	576	{
543	return isascii (c) && isdigit (c);	577	return isascii (c) && isdigit (c);
544	}	578	}
545		579
546	static INLINE int	580	ecb_inline int
547	Cisspace (int c)	581	Cisspace (int c)
548	{	582	{
549	return isascii (c) && isspace (c);	583	return isascii (c) && isspace (c);
550	}	584	}
551		585
552	static INLINE int	586	ecb_inline int
553	Cisupper (int c)	587	Cisupper (int c)
554	{	588	{
555	return isascii (c) && isupper (c);	589	return isascii (c) && isupper (c);
556	}	590	}
557		591
558	static INLINE int	592	ecb_inline int
559	Cislower (int c)	593	Cislower (int c)
560	{	594	{
561	return isascii (c) && islower (c);	595	return isascii (c) && islower (c);
562	}	596	}
563	#endif	597	#endif
…		…
624	#endif	658	#endif
625		659
626	static int file_push (SCHEME_P_ const char *fname);	660	static int file_push (SCHEME_P_ const char *fname);
627	static void file_pop (SCHEME_P);	661	static void file_pop (SCHEME_P);
628	static int file_interactive (SCHEME_P);	662	static int file_interactive (SCHEME_P);
629	static INLINE int is_one_of (char *s, int c);	663	ecb_inline int is_one_of (char *s, int c);
630	static int alloc_cellseg (SCHEME_P_ int n);	664	static int alloc_cellseg (SCHEME_P_ int n);
631	static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b);	665	ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
632	static void finalize_cell (SCHEME_P_ pointer a);	666	static void finalize_cell (SCHEME_P_ pointer a);
633	static int count_consecutive_cells (pointer x, int needed);	667	static int count_consecutive_cells (pointer x, int needed);
634	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);	668	static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
635	static pointer mk_number (SCHEME_P_ const num n);	669	static pointer mk_number (SCHEME_P_ const num n);
636	static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);	670	static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
…		…
653	static int basic_inchar (port *pt);	687	static int basic_inchar (port *pt);
654	static int inchar (SCHEME_P);	688	static int inchar (SCHEME_P);
655	static void backchar (SCHEME_P_ int c);	689	static void backchar (SCHEME_P_ int c);
656	static char *readstr_upto (SCHEME_P_ char *delim);	690	static char *readstr_upto (SCHEME_P_ char *delim);
657	static pointer readstrexp (SCHEME_P);	691	static pointer readstrexp (SCHEME_P);
658	static INLINE int skipspace (SCHEME_P);	692	ecb_inline int skipspace (SCHEME_P);
659	static int token (SCHEME_P);	693	static int token (SCHEME_P);
660	static void printslashstring (SCHEME_P_ char *s, int len);	694	static void printslashstring (SCHEME_P_ char *s, int len);
661	static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);	695	static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
662	static void printatom (SCHEME_P_ pointer l, int f);	696	static void printatom (SCHEME_P_ pointer l, int f);
663	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);	697	static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
…		…
679	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);	713	static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
680	static void assign_syntax (SCHEME_P_ const char *name);	714	static void assign_syntax (SCHEME_P_ const char *name);
681	static int syntaxnum (pointer p);	715	static int syntaxnum (pointer p);
682	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);	716	static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
683		717
		718	static IVALUE
		719	ivalue (pointer x)
		720	{
		721	return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
		722	}
		723
		724	static RVALUE
		725	rvalue (pointer x)
		726	{
		727	return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
		728	}
		729
		730	INTERFACE num
		731	nvalue (pointer x)
		732	{
		733	num n;
		734
		735	num_set_fixnum (n, is_integer (x));
		736
		737	if (num_is_fixnum (n))
		738	num_set_ivalue (n, ivalue_unchecked (x));
		739	else
		740	num_set_rvalue (n, rvalue_unchecked (x));
		741
		742	return n;
		743	}
		744
684	static num	745	static num
685	num_op (enum num_op op, num a, num b)	746	num_op (enum num_op op, num a, num b)
686	{	747	{
687	num ret;	748	num ret;
688		749
689	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	750	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
690		751
691	if (num_is_fixnum (ret))	752	if (num_is_fixnum (ret))
692	{	753	{
693	IVALUE av = num_get_ivalue (a);
694	IVALUE bv = num_get_ivalue (b);
695
696	switch (op)	754	switch (op)
697	{	755	{
698	case NUM_ADD: av += bv; break;	756	case NUM_ADD: a.ivalue += b.ivalue; break;
699	case NUM_SUB: av -= bv; break;	757	case NUM_SUB: a.ivalue -= b.ivalue; break;
700	case NUM_MUL: av *= bv; break;	758	case NUM_MUL: a.ivalue *= b.ivalue; break;
701	case NUM_INTDIV: av /= bv; break;	759	case NUM_INTDIV: a.ivalue /= b.ivalue; break;
702	}	760	}
703		761
704	num_set_ivalue (ret, av);	762	num_set_ivalue (ret, a.ivalue);
705	}	763	}
		764	#if USE_REAL
706	else	765	else
707	{	766	{
708	RVALUE av = num_get_rvalue (a);
709	RVALUE bv = num_get_rvalue (b);
710
711	switch (op)	767	switch (op)
712	{	768	{
713	case NUM_ADD: av += bv; break;	769	case NUM_ADD: a.rvalue += b.rvalue; break;
714	case NUM_SUB: av -= bv; break;	770	case NUM_SUB: a.rvalue -= b.rvalue; break;
715	case NUM_MUL: av *= bv; break;	771	case NUM_MUL: a.rvalue *= b.rvalue; break;
716	case NUM_INTDIV: av /= bv; break;	772	case NUM_INTDIV: a.rvalue /= b.rvalue; break;
717	}	773	}
718		774
719	num_set_rvalue (ret, av);	775	num_set_rvalue (ret, a.rvalue);
720	}	776	}
		777	#endif
721		778
722	return ret;	779	return ret;
723	}	780	}
724		781
725	static num	782	static num
726	num_div (num a, num b)	783	num_div (num a, num b)
727	{	784	{
728	num ret;	785	num ret;
729		786
730	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0);	787	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0);
731		788
732	if (num_is_fixnum (ret))	789	if (num_is_fixnum (ret))
733	num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));	790	num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b));
734	else	791	else
735	num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));	792	num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b));
736		793
737	return ret;	794	return ret;
738	}	795	}
739		796
740	static num	797	static num
…		…
742	{	799	{
743	num ret;	800	num ret;
744	long e1, e2, res;	801	long e1, e2, res;
745		802
746	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	803	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
747	e1 = num_get_ivalue (a);	804	e1 = num_ivalue (a);
748	e2 = num_get_ivalue (b);	805	e2 = num_ivalue (b);
749	res = e1 % e2;	806	res = e1 % e2;
750		807
751	/* remainder should have same sign as second operand */	808	/* remainder should have same sign as second operand */
752	if (res > 0)	809	if (res > 0)
753	{	810	{
…		…
769	{	826	{
770	num ret;	827	num ret;
771	long e1, e2, res;	828	long e1, e2, res;
772		829
773	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));	830	num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
774	e1 = num_get_ivalue (a);	831	e1 = num_ivalue (a);
775	e2 = num_get_ivalue (b);	832	e2 = num_ivalue (b);
776	res = e1 % e2;	833	res = e1 % e2;
777		834
778	/* modulo should have same sign as second operand */	835	/* modulo should have same sign as second operand */
779	if (res * e2 < 0)	836	if (res * e2 < 0)
780	res += e2;	837	res += e2;
781		838
782	num_set_ivalue (ret, res);	839	num_set_ivalue (ret, res);
783	return ret;	840	return ret;
784	}	841	}
785		842
786	/* this completely disrespects NaNs */	843	/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
787	static int	844	static int
788	num_cmp (num a, num b)	845	num_cmp (num a, num b)
789	{	846	{
790	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);	847	int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
791	int ret;	848	int ret;
792		849
793	if (is_fixnum)	850	if (is_fixnum)
794	{	851	{
795	IVALUE av = num_get_ivalue (a);	852	IVALUE av = num_ivalue (a);
796	IVALUE bv = num_get_ivalue (b);	853	IVALUE bv = num_ivalue (b);
797		854
798	ret = av == bv ? 0 : av < bv ? -1 : +1;	855	ret = av == bv ? 0 : av < bv ? -1 : +1;
799	}	856	}
800	else	857	else
801	{	858	{
802	RVALUE av = num_get_rvalue (a);	859	RVALUE av = num_rvalue (a);
803	RVALUE bv = num_get_rvalue (b);	860	RVALUE bv = num_rvalue (b);
804		861
805	ret = av == bv ? 0 : av < bv ? -1 : +1;	862	ret = av == bv ? 0 : av < bv ? -1 : +1;
806	}	863	}
807		864
808	return ret;	865	return ret;
…		…
834	#endif	891	#endif
835		892
836	static int	893	static int
837	is_zero_rvalue (RVALUE x)	894	is_zero_rvalue (RVALUE x)
838	{	895	{
		896	return x == 0;
		897	#if 0
839	#if USE_REAL	898	#if USE_REAL
840	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */	899	return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
841	#else	900	#else
842	return x == 0;	901	return x == 0;
		902	#endif
843	#endif	903	#endif
844	}	904	}
845		905
846	/* allocate new cell segment */	906	/* allocate new cell segment */
847	static int	907	static int
…		…
892	SCHEME_V->fcells += segsize;	952	SCHEME_V->fcells += segsize;
893	last = newp + segsize - 1;	953	last = newp + segsize - 1;
894		954
895	for (p = newp; p <= last; p++)	955	for (p = newp; p <= last; p++)
896	{	956	{
897	set_typeflag (p, T_FREE);	957	set_typeflag (p, T_PAIR);
898	set_car (p, NIL);	958	set_car (p, NIL);
899	set_cdr (p, p + 1);	959	set_cdr (p, p + 1);
900	}	960	}
901		961
902	/* insert new cells in address order on free list */	962	/* insert new cells in address order on free list */
…		…
919		979
920	return n;	980	return n;
921	}	981	}
922		982
923	/* get new cell. parameter a, b is marked by gc. */	983	/* get new cell. parameter a, b is marked by gc. */
924	static INLINE pointer	984	ecb_inline pointer
925	get_cell_x (SCHEME_P_ pointer a, pointer b)	985	get_cell_x (SCHEME_P_ pointer a, pointer b)
926	{	986	{
927	if (ecb_expect_false (SCHEME_V->free_cell == NIL))	987	if (ecb_expect_false (SCHEME_V->free_cell == NIL))
928	{	988	{
929	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)	989	if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
…		…
1007	push_recent_alloc (SCHEME_A_ v, NIL);	1067	push_recent_alloc (SCHEME_A_ v, NIL);
1008		1068
1009	return v;	1069	return v;
1010	}	1070	}
1011		1071
1012	static INLINE void	1072	ecb_inline void
1013	ok_to_freely_gc (SCHEME_P)	1073	ok_to_freely_gc (SCHEME_P)
1014	{	1074	{
1015	set_car (S_SINK, NIL);	1075	set_car (S_SINK, NIL);
1016	}	1076	}
1017		1077
…		…
1081	location = hash_fn (name, veclength (SCHEME_V->oblist));	1141	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)));	1142	set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location)));
1083	return x;	1143	return x;
1084	}	1144	}
1085		1145
1086	static INLINE pointer	1146	ecb_inline pointer
1087	oblist_find_by_name (SCHEME_P_ const char *name)	1147	oblist_find_by_name (SCHEME_P_ const char *name)
1088	{	1148	{
1089	int location;	1149	int location;
1090	pointer x;	1150	pointer x;
1091	char *s;	1151	char *s;
…		…
1124	oblist_initial_value (SCHEME_P)	1184	oblist_initial_value (SCHEME_P)
1125	{	1185	{
1126	return NIL;	1186	return NIL;
1127	}	1187	}
1128		1188
1129	static INLINE pointer	1189	ecb_inline pointer
1130	oblist_find_by_name (SCHEME_P_ const char *name)	1190	oblist_find_by_name (SCHEME_P_ const char *name)
1131	{	1191	{
1132	pointer x;	1192	pointer x;
1133	char *s;	1193	char *s;
1134		1194
…		…
1193	mk_character (SCHEME_P_ int c)	1253	mk_character (SCHEME_P_ int c)
1194	{	1254	{
1195	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1255	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1196		1256
1197	set_typeflag (x, (T_CHARACTER | T_ATOM));	1257	set_typeflag (x, (T_CHARACTER | T_ATOM));
1198	ivalue_unchecked (x) = c & 0xff;	1258	set_ivalue (x, c & 0xff);
1199	set_num_integer (x);	1259
1200	return x;	1260	return x;
1201	}	1261	}
1202		1262
1203	/* get number atom (integer) */	1263	/* get number atom (integer) */
1204	INTERFACE pointer	1264	INTERFACE pointer
1205	mk_integer (SCHEME_P_ long num)	1265	mk_integer (SCHEME_P_ long n)
1206	{	1266	{
1207	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1267	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1208		1268
1209	set_typeflag (x, (T_NUMBER | T_ATOM));	1269	set_typeflag (x, (T_INTEGER | T_ATOM));
1210	ivalue_unchecked (x) = num;	1270	set_ivalue (x, n);
1211	set_num_integer (x);	1271
1212	return x;	1272	return x;
1213	}	1273	}
1214		1274
1215	INTERFACE pointer	1275	INTERFACE pointer
1216	mk_real (SCHEME_P_ RVALUE n)	1276	mk_real (SCHEME_P_ RVALUE n)
1217	{	1277	{
		1278	#if USE_REAL
1218	pointer x = get_cell (SCHEME_A_ NIL, NIL);	1279	pointer x = get_cell (SCHEME_A_ NIL, NIL);
1219		1280
1220	set_typeflag (x, (T_NUMBER | T_ATOM));	1281	set_typeflag (x, (T_REAL | T_ATOM));
1221	rvalue_unchecked (x) = n;	1282	set_rvalue (x, n);
1222	set_num_real (x);	1283
1223	return x;	1284	return x;
		1285	#else
		1286	return mk_integer (SCHEME_A_ n);
		1287	#endif
1224	}	1288	}
1225		1289
1226	static pointer	1290	static pointer
1227	mk_number (SCHEME_P_ const num n)	1291	mk_number (SCHEME_P_ const num n)
1228	{	1292	{
		1293	#if USE_REAL
1229	if (num_is_fixnum (n))	1294	return num_is_fixnum (n)
		1295	? mk_integer (SCHEME_A_ num_ivalue (n))
		1296	: mk_real (SCHEME_A_ num_rvalue (n));
		1297	#else
1230	return mk_integer (SCHEME_A_ num_get_ivalue (n));	1298	return mk_integer (SCHEME_A_ num_ivalue (n));
1231	else	1299	#endif
1232	return mk_real (SCHEME_A_ num_get_rvalue (n));
1233	}	1300	}
1234		1301
1235	/* allocate name to string area */	1302	/* allocate name to string area */
1236	static char *	1303	static char *
1237	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)	1304	store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
…		…
1413	}	1480	}
1414	else if ((c == 'e') || (c == 'E'))	1481	else if ((c == 'e') || (c == 'E'))
1415	{	1482	{
1416	if (!has_fp_exp)	1483	if (!has_fp_exp)
1417	{	1484	{
1418	has_dec_point = 1; /* decimal point illegal	1485	has_dec_point = 1; /* decimal point illegal from now on */
1419	from now on */
1420	p++;	1486	p++;
1421		1487
1422	if ((*p == '-') || (*p == '+') || isdigit (*p))	1488	if ((*p == '-') || (*p == '+') || isdigit (*p))
1423	continue;	1489	continue;
1424	}	1490	}
…		…
1620	if (is_mark (p))	1686	if (is_mark (p))
1621	clrmark (p);	1687	clrmark (p);
1622	else	1688	else
1623	{	1689	{
1624	/* reclaim cell */	1690	/* reclaim cell */
1625	if (typeflag (p) != T_FREE)	1691	if (typeflag (p) != T_PAIR)
1626	{	1692	{
1627	finalize_cell (SCHEME_A_ p);	1693	finalize_cell (SCHEME_A_ p);
1628	set_typeflag (p, T_FREE);	1694	set_typeflag (p, T_PAIR);
1629	set_car (p, NIL);	1695	set_car (p, NIL);
1630	}	1696	}
1631		1697
1632	++SCHEME_V->fcells;	1698	++SCHEME_V->fcells;
1633	set_cdr (p, SCHEME_V->free_cell);	1699	set_cdr (p, SCHEME_V->free_cell);
…		…
1635	}	1701	}
1636	}	1702	}
1637	}	1703	}
1638		1704
1639	if (SCHEME_V->gc_verbose)	1705	if (SCHEME_V->gc_verbose)
		1706	{
1640	xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");	1707	xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");
		1708	}
1641	}	1709	}
1642		1710
1643	static void	1711	static void
1644	finalize_cell (SCHEME_P_ pointer a)	1712	finalize_cell (SCHEME_P_ pointer a)
1645	{	1713	{
…		…
2232	}	2300	}
2233	}	2301	}
2234	}	2302	}
2235		2303
2236	/* check c is in chars */	2304	/* check c is in chars */
2237	static INLINE int	2305	ecb_inline int
2238	is_one_of (char *s, int c)	2306	is_one_of (char *s, int c)
2239	{	2307	{
2240	if (c == EOF)	2308	if (c == EOF)
2241	return 1;	2309	return 1;
2242		2310
2243	return !!strchr (s, c);	2311	return !!strchr (s, c);
2244	}	2312	}
2245		2313
2246	/* skip white characters */	2314	/* skip white characters */
2247	static INLINE int	2315	ecb_inline int
2248	skipspace (SCHEME_P)	2316	skipspace (SCHEME_P)
2249	{	2317	{
2250	int c, curr_line = 0;	2318	int c, curr_line = 0;
2251		2319
2252	do	2320	do
…		…
2480	{	2548	{
2481	p = SCHEME_V->strbuff;	2549	p = SCHEME_V->strbuff;
2482		2550
2483	if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */	2551	if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2484	{	2552	{
2485	if (num_is_integer (l))	2553	if (is_integer (l))
2486	xnum (p, ivalue_unchecked (l));	2554	xnum (p, ivalue_unchecked (l));
2487	#if USE_REAL	2555	#if USE_REAL
2488	else	2556	else
2489	{	2557	{
2490	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));	2558	snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
…		…
2745	return 0;	2813	return 0;
2746	}	2814	}
2747	else if (is_number (a))	2815	else if (is_number (a))
2748	{	2816	{
2749	if (is_number (b))	2817	if (is_number (b))
2750	if (num_is_integer (a) == num_is_integer (b))
2751	return num_cmp (nvalue (a), nvalue (b)) == 0;	2818	return num_cmp (nvalue (a), nvalue (b)) == 0;
2752		2819
2753	return 0;	2820	return 0;
2754	}	2821	}
2755	else if (is_character (a))	2822	else if (is_character (a))
2756	{	2823	{
…		…
2823		2890
2824	SCHEME_V->envir = immutable_cons (new_frame, old_env);	2891	SCHEME_V->envir = immutable_cons (new_frame, old_env);
2825	setenvironment (SCHEME_V->envir);	2892	setenvironment (SCHEME_V->envir);
2826	}	2893	}
2827		2894
2828	static INLINE void	2895	ecb_inline void
2829	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2896	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2830	{	2897	{
2831	pointer slot = immutable_cons (variable, value);	2898	pointer slot = immutable_cons (variable, value);
2832		2899
2833	if (is_vector (car (env)))	2900	if (is_vector (car (env)))
…		…
2873	return NIL;	2940	return NIL;
2874	}	2941	}
2875		2942
2876	#else /* USE_ALIST_ENV */	2943	#else /* USE_ALIST_ENV */
2877		2944
2878	static INLINE void	2945	ecb_inline void
2879	new_frame_in_env (SCHEME_P_ pointer old_env)	2946	new_frame_in_env (SCHEME_P_ pointer old_env)
2880	{	2947	{
2881	SCHEME_V->envir = immutable_cons (NIL, old_env);	2948	SCHEME_V->envir = immutable_cons (NIL, old_env);
2882	setenvironment (SCHEME_V->envir);	2949	setenvironment (SCHEME_V->envir);
2883	}	2950	}
2884		2951
2885	static INLINE void	2952	ecb_inline void
2886	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)	2953	new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2887	{	2954	{
2888	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));	2955	set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2889	}	2956	}
2890		2957
…		…
2912	return NIL;	2979	return NIL;
2913	}	2980	}
2914		2981
2915	#endif /* USE_ALIST_ENV else */	2982	#endif /* USE_ALIST_ENV else */
2916		2983
2917	static INLINE void	2984	ecb_inline void
2918	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)	2985	new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2919	{	2986	{
2920	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);	2987	new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2921	}	2988	}
2922		2989
2923	static INLINE void	2990	ecb_inline void
2924	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)	2991	set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2925	{	2992	{
2926	set_cdr (slot, value);	2993	set_cdr (slot, value);
2927	}	2994	}
2928		2995
2929	static INLINE pointer	2996	ecb_inline pointer
2930	slot_value_in_env (pointer slot)	2997	slot_value_in_env (pointer slot)
2931	{	2998	{
2932	return cdr (slot);	2999	return cdr (slot);
2933	}	3000	}
2934		3001
…		…
3062	SCHEME_V->dump = (pointer)(uintptr_t)nframes;	3129	SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3063		3130
3064	return 0;	3131	return 0;
3065	}	3132	}
3066		3133
3067	static INLINE void	3134	ecb_inline void
3068	dump_stack_reset (SCHEME_P)	3135	dump_stack_reset (SCHEME_P)
3069	{	3136	{
3070	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */	3137	/* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3071	SCHEME_V->dump = (pointer)+0;	3138	SCHEME_V->dump = (pointer)+0;
3072	}	3139	}
3073		3140
3074	static INLINE void	3141	ecb_inline void
3075	dump_stack_initialize (SCHEME_P)	3142	dump_stack_initialize (SCHEME_P)
3076	{	3143	{
3077	SCHEME_V->dump_size = 0;	3144	SCHEME_V->dump_size = 0;
3078	SCHEME_V->dump_base = 0;	3145	SCHEME_V->dump_base = 0;
3079	dump_stack_reset (SCHEME_A);	3146	dump_stack_reset (SCHEME_A);
…		…
3132	int i = 0;	3199	int i = 0;
3133	struct dump_stack_frame *frame = SCHEME_V->dump_base;	3200	struct dump_stack_frame *frame = SCHEME_V->dump_base;
3134		3201
3135	while (cont != NIL)	3202	while (cont != NIL)
3136	{	3203	{
3137	frame->op = ivalue (car (cont)); cont = cdr (cont);	3204	frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont);
3138	frame->args = car (cont) ; cont = cdr (cont);	3205	frame->args = car (cont) ; cont = cdr (cont);
3139	frame->envir = car (cont) ; cont = cdr (cont);	3206	frame->envir = car (cont) ; cont = cdr (cont);
3140	frame->code = car (cont) ; cont = cdr (cont);	3207	frame->code = car (cont) ; cont = cdr (cont);
3141		3208
3142	++frame;	3209	++frame;
3143	++i;	3210	++i;
3144	}	3211	}
3145		3212
3146	SCHEME_V->dump = (pointer)(uintptr_t)i;	3213	SCHEME_V->dump = (pointer)(uintptr_t)i;
3147	}	3214	}
3148		3215
3149	#else	3216	#else
3150		3217
3151	static INLINE void	3218	ecb_inline void
3152	dump_stack_reset (SCHEME_P)	3219	dump_stack_reset (SCHEME_P)
3153	{	3220	{
3154	SCHEME_V->dump = NIL;	3221	SCHEME_V->dump = NIL;
3155	}	3222	}
3156		3223
3157	static INLINE void	3224	ecb_inline void
3158	dump_stack_initialize (SCHEME_P)	3225	dump_stack_initialize (SCHEME_P)
3159	{	3226	{
3160	dump_stack_reset (SCHEME_A);	3227	dump_stack_reset (SCHEME_A);
3161	}	3228	}
3162		3229
…		…
3174	SCHEME_V->value = a;	3241	SCHEME_V->value = a;
3175		3242
3176	if (dump == NIL)	3243	if (dump == NIL)
3177	return -1;	3244	return -1;
3178		3245
3179	SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump);	3246	SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump);
3180	SCHEME_V->args = car (dump) ; dump = cdr (dump);	3247	SCHEME_V->args = car (dump) ; dump = cdr (dump);
3181	SCHEME_V->envir = car (dump) ; dump = cdr (dump);	3248	SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3182	SCHEME_V->code = car (dump) ; dump = cdr (dump);	3249	SCHEME_V->code = car (dump) ; dump = cdr (dump);
3183		3250
3184	SCHEME_V->dump = dump;	3251	SCHEME_V->dump = dump;
3185		3252
3186	return 0;	3253	return 0;
3187	}	3254	}
…		…
3393		3460
3394	case OP_TRACING:	3461	case OP_TRACING:
3395	{	3462	{
3396	int tr = SCHEME_V->tracing;	3463	int tr = SCHEME_V->tracing;
3397		3464
3398	SCHEME_V->tracing = ivalue (car (args));	3465	SCHEME_V->tracing = ivalue_unchecked (car (args));
3399	s_return (mk_integer (SCHEME_A_ tr));	3466	s_return (mk_integer (SCHEME_A_ tr));
3400	}	3467	}
3401		3468
3402	#endif	3469	#endif
3403		3470
…		…
3912	SCHEME_V->code = car (args);	3979	SCHEME_V->code = car (args);
3913	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);	3980	SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3914	s_goto (OP_APPLY);	3981	s_goto (OP_APPLY);
3915	}	3982	}
3916		3983
3917	abort ();	3984	if (USE_ERROR_CHECKING) abort ();
3918	}	3985	}
3919		3986
3920	static int	3987	static int
3921	opexe_1 (SCHEME_P_ enum scheme_opcodes op)	3988	opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3922	{	3989	{
3923	pointer args = SCHEME_V->args;	3990	pointer args = SCHEME_V->args;
3924	pointer x = car (args);	3991	pointer x = car (args);
3925	num v;	3992	num v;
3926		3993
3927	#if USE_MATH
3928	RVALUE dd;
3929	#endif
3930
3931	switch (op)	3994	switch (op)
3932	{	3995	{
3933	#if USE_MATH	3996	#if USE_MATH
3934	case OP_INEX2EX: /* inexact->exact */	3997	case OP_INEX2EX: /* inexact->exact */
		3998	{
3935	if (num_is_integer (x))	3999	if (is_integer (x))
3936	s_return (x);	4000	s_return (x);
3937	else if (modf (rvalue_unchecked (x), &dd) == 0)	4001
		4002	RVALUE r = rvalue_unchecked (x);
		4003
		4004	if (r == (RVALUE)(IVALUE)r)
3938	s_return (mk_integer (SCHEME_A_ ivalue (x)));	4005	s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x)));
3939	else	4006	else
3940	Error_1 ("inexact->exact: not integral:", x);	4007	Error_1 ("inexact->exact: not integral:", x);
		4008	}
3941		4009
3942	case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));	4010	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))));	4011	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))));	4012	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))));	4013	case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
…		…
3963	{	4031	{
3964	RVALUE result;	4032	RVALUE result;
3965	int real_result = 1;	4033	int real_result = 1;
3966	pointer y = cadr (args);	4034	pointer y = cadr (args);
3967		4035
3968	if (num_is_integer (x) && num_is_integer (y))	4036	if (is_integer (x) && is_integer (y))
3969	real_result = 0;	4037	real_result = 0;
3970		4038
3971	/* This 'if' is an R5RS compatibility fix. */	4039	/* This 'if' is an R5RS compatibility fix. */
3972	/* NOTE: Remove this 'if' fix for R6RS. */	4040	/* NOTE: Remove this 'if' fix for R6RS. */
3973	if (rvalue (x) == 0 && rvalue (y) < 0)	4041	if (rvalue (x) == 0 && rvalue (y) < 0)
…		…
3979	/* If the test fails, result is too big for integer. */	4047	/* If the test fails, result is too big for integer. */
3980	if (!real_result)	4048	if (!real_result)
3981	{	4049	{
3982	long result_as_long = result;	4050	long result_as_long = result;
3983		4051
3984	if (result != (RVALUE) result_as_long)	4052	if (result != result_as_long)
3985	real_result = 1;	4053	real_result = 1;
3986	}	4054	}
3987		4055
3988	if (real_result)	4056	if (real_result)
3989	s_return (mk_real (SCHEME_A_ result));	4057	s_return (mk_real (SCHEME_A_ result));
…		…
3994	case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));	4062	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))));	4063	case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
3996		4064
3997	case OP_TRUNCATE:	4065	case OP_TRUNCATE:
3998	{	4066	{
3999	RVALUE rvalue_of_x;	4067	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)));	4068	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	}	4069	}
4008		4070
4009	case OP_ROUND:	4071	case OP_ROUND:
4010	if (num_is_integer (x))	4072	if (is_integer (x))
4011	s_return (x);	4073	s_return (x);
4012		4074
4013	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));	4075	s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4014	#endif	4076	#endif
4015		4077
4016	case OP_ADD: /* + */	4078	case OP_ADD: /* + */
4017	v = num_zero;	4079	v = num_zero;
4018		4080
4019	for (x = args; x != NIL; x = cdr (x))	4081	for (x = args; x != NIL; x = cdr (x))
4020	v = num_op ('+', v, nvalue (car (x)));	4082	v = num_op (NUM_ADD, v, nvalue (car (x)));
4021		4083
4022	s_return (mk_number (SCHEME_A_ v));	4084	s_return (mk_number (SCHEME_A_ v));
4023		4085
4024	case OP_MUL: /* * */	4086	case OP_MUL: /* * */
4025	v = num_one;	4087	v = num_one;
4026		4088
4027	for (x = args; x != NIL; x = cdr (x))	4089	for (x = args; x != NIL; x = cdr (x))
4028	v = num_op ('*', v, nvalue (car (x)));	4090	v = num_op (NUM_MUL, v, nvalue (car (x)));
4029		4091
4030	s_return (mk_number (SCHEME_A_ v));	4092	s_return (mk_number (SCHEME_A_ v));
4031		4093
4032	case OP_SUB: /* - */	4094	case OP_SUB: /* - */
4033	if (cdr (args) == NIL)	4095	if (cdr (args) == NIL)
…		…
4040	x = cdr (args);	4102	x = cdr (args);
4041	v = nvalue (car (args));	4103	v = nvalue (car (args));
4042	}	4104	}
4043		4105
4044	for (; x != NIL; x = cdr (x))	4106	for (; x != NIL; x = cdr (x))
4045	v = num_op ('-', v, nvalue (car (x)));	4107	v = num_op (NUM_SUB, v, nvalue (car (x)));
4046		4108
4047	s_return (mk_number (SCHEME_A_ v));	4109	s_return (mk_number (SCHEME_A_ v));
4048		4110
4049	case OP_DIV: /* / */	4111	case OP_DIV: /* / */
4050	if (cdr (args) == NIL)	4112	if (cdr (args) == NIL)
…		…
4057	x = cdr (args);	4119	x = cdr (args);
4058	v = nvalue (car (args));	4120	v = nvalue (car (args));
4059	}	4121	}
4060		4122
4061	for (; x != NIL; x = cdr (x))	4123	for (; x != NIL; x = cdr (x))
4062	{
4063	if (!is_zero_rvalue (rvalue (car (x))))	4124	if (!is_zero_rvalue (rvalue (car (x))))
4064	v = num_div (v, nvalue (car (x)));	4125	v = num_div (v, nvalue (car (x)));
4065	else	4126	else
4066	Error_0 ("/: division by zero");	4127	Error_0 ("/: division by zero");
4067	}
4068		4128
4069	s_return (mk_number (SCHEME_A_ v));	4129	s_return (mk_number (SCHEME_A_ v));
4070		4130
4071	case OP_INTDIV: /* quotient */	4131	case OP_INTDIV: /* quotient */
4072	if (cdr (args) == NIL)	4132	if (cdr (args) == NIL)
…		…
4081	}	4141	}
4082		4142
4083	for (; x != NIL; x = cdr (x))	4143	for (; x != NIL; x = cdr (x))
4084	{	4144	{
4085	if (ivalue (car (x)) != 0)	4145	if (ivalue (car (x)) != 0)
4086	v = num_op ('/', v, nvalue (car (x)));	4146	v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4087	else	4147	else
4088	Error_0 ("quotient: division by zero");	4148	Error_0 ("quotient: division by zero");
4089	}	4149	}
4090		4150
4091	s_return (mk_number (SCHEME_A_ v));	4151	s_return (mk_number (SCHEME_A_ v));
…		…
4137	}	4197	}
4138	else	4198	else
4139	Error_0 ("set-cdr!: unable to alter immutable pair");	4199	Error_0 ("set-cdr!: unable to alter immutable pair");
4140		4200
4141	case OP_CHAR2INT: /* char->integer */	4201	case OP_CHAR2INT: /* char->integer */
4142	s_return (mk_integer (SCHEME_A_ ivalue (x)));	4202	s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x)));
4143		4203
4144	case OP_INT2CHAR: /* integer->char */	4204	case OP_INT2CHAR: /* integer->char */
4145	s_return (mk_character (SCHEME_A_ ivalue (x)));	4205	s_return (mk_character (SCHEME_A_ ivalue_unchecked (x)));
4146		4206
4147	case OP_CHARUPCASE:	4207	case OP_CHARUPCASE:
4148	{	4208	{
4149	unsigned char c = ivalue (x);	4209	unsigned char c = ivalue_unchecked (x);
4150	c = toupper (c);	4210	c = toupper (c);
4151	s_return (mk_character (SCHEME_A_ c));	4211	s_return (mk_character (SCHEME_A_ c));
4152	}	4212	}
4153		4213
4154	case OP_CHARDNCASE:	4214	case OP_CHARDNCASE:
4155	{	4215	{
4156	unsigned char c = ivalue (x);	4216	unsigned char c = ivalue_unchecked (x);
4157	c = tolower (c);	4217	c = tolower (c);
4158	s_return (mk_character (SCHEME_A_ c));	4218	s_return (mk_character (SCHEME_A_ c));
4159	}	4219	}
4160		4220
4161	case OP_STR2SYM: /* string->symbol */	4221	case OP_STR2SYM: /* string->symbol */
…		…
4238	Error_1 ("atom->string: not an atom:", x);	4298	Error_1 ("atom->string: not an atom:", x);
4239	}	4299	}
4240		4300
4241	case OP_MKSTRING: /* make-string */	4301	case OP_MKSTRING: /* make-string */
4242	{	4302	{
4243	int fill = ' ';	4303	int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' ';
4244	int len;
4245
4246	len = ivalue (x);	4304	int len = ivalue_unchecked (x);
4247
4248	if (cdr (args) != NIL)
4249	fill = charvalue (cadr (args));
4250		4305
4251	s_return (mk_empty_string (SCHEME_A_ len, fill));	4306	s_return (mk_empty_string (SCHEME_A_ len, fill));
4252	}	4307	}
4253		4308
4254	case OP_STRLEN: /* string-length */	4309	case OP_STRLEN: /* string-length */
4255	s_return (mk_integer (SCHEME_A_ strlength (x)));	4310	s_return (mk_integer (SCHEME_A_ strlength (x)));
4256		4311
4257	case OP_STRREF: /* string-ref */	4312	case OP_STRREF: /* string-ref */
4258	{	4313	{
4259	char *str;
4260	int index;
4261
4262	str = strvalue (x);	4314	char *str = strvalue (x);
4263
4264	index = ivalue (cadr (args));	4315	int index = ivalue_unchecked (cadr (args));
4265		4316
4266	if (index >= strlength (x))	4317	if (index >= strlength (x))
4267	Error_1 ("string-ref: out of bounds:", cadr (args));	4318	Error_1 ("string-ref: out of bounds:", cadr (args));
4268		4319
4269	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));	4320	s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4270	}	4321	}
4271		4322
4272	case OP_STRSET: /* string-set! */	4323	case OP_STRSET: /* string-set! */
4273	{	4324	{
4274	char *str;	4325	char *str = strvalue (x);
4275	int index;	4326	int index = ivalue_unchecked (cadr (args));
4276	int c;	4327	int c;
4277		4328
4278	if (is_immutable (x))	4329	if (is_immutable (x))
4279	Error_1 ("string-set!: unable to alter immutable string:", x);	4330	Error_1 ("string-set!: unable to alter immutable string:", x);
4280
4281	str = strvalue (x);
4282
4283	index = ivalue (cadr (args));
4284		4331
4285	if (index >= strlength (x))	4332	if (index >= strlength (x))
4286	Error_1 ("string-set!: out of bounds:", cadr (args));	4333	Error_1 ("string-set!: out of bounds:", cadr (args));
4287		4334
4288	c = charvalue (caddr (args));	4335	c = charvalue (caddr (args));
…		…
4311	s_return (newstr);	4358	s_return (newstr);
4312	}	4359	}
4313		4360
4314	case OP_SUBSTR: /* substring */	4361	case OP_SUBSTR: /* substring */
4315	{	4362	{
4316	char *str;	4363	char *str = strvalue (x);
4317	int index0;	4364	int index0 = ivalue_unchecked (cadr (args));
4318	int index1;	4365	int index1;
4319	int len;	4366	int len;
4320		4367
4321	str = strvalue (x);
4322
4323	index0 = ivalue (cadr (args));
4324
4325	if (index0 > strlength (x))	4368	if (index0 > strlength (x))
4326	Error_1 ("substring: start out of bounds:", cadr (args));	4369	Error_1 ("substring: start out of bounds:", cadr (args));
4327		4370
4328	if (cddr (args) != NIL)	4371	if (cddr (args) != NIL)
4329	{	4372	{
4330	index1 = ivalue (caddr (args));	4373	index1 = ivalue_unchecked (caddr (args));
4331		4374
4332	if (index1 > strlength (x) || index1 < index0)	4375	if (index1 > strlength (x) || index1 < index0)
4333	Error_1 ("substring: end out of bounds:", caddr (args));	4376	Error_1 ("substring: end out of bounds:", caddr (args));
4334	}	4377	}
4335	else	4378	else
…		…
4366	}	4409	}
4367		4410
4368	case OP_MKVECTOR: /* make-vector */	4411	case OP_MKVECTOR: /* make-vector */
4369	{	4412	{
4370	pointer fill = NIL;	4413	pointer fill = NIL;
4371	int len;
4372	pointer vec;	4414	pointer vec;
4373
4374	len = ivalue (x);	4415	int len = ivalue_unchecked (x);
4375		4416
4376	if (cdr (args) != NIL)	4417	if (cdr (args) != NIL)
4377	fill = cadr (args);	4418	fill = cadr (args);
4378		4419
4379	vec = mk_vector (SCHEME_A_ len);	4420	vec = mk_vector (SCHEME_A_ len);
…		…
4392	case OP_VECLEN: /* vector-length */	4433	case OP_VECLEN: /* vector-length */
4393	s_return (mk_integer (SCHEME_A_ veclength (x)));	4434	s_return (mk_integer (SCHEME_A_ veclength (x)));
4394		4435
4395	case OP_VECREF: /* vector-ref */	4436	case OP_VECREF: /* vector-ref */
4396	{	4437	{
4397	int index;
4398
4399	index = ivalue (cadr (args));	4438	int index = ivalue_unchecked (cadr (args));
4400		4439
4401	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)	4440	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4402	Error_1 ("vector-ref: out of bounds:", cadr (args));	4441	Error_1 ("vector-ref: out of bounds:", cadr (args));
4403		4442
4404	s_return (vector_elem (x, index));	4443	s_return (vector_elem (x, index));
4405	}	4444	}
4406		4445
4407	case OP_VECSET: /* vector-set! */	4446	case OP_VECSET: /* vector-set! */
4408	{	4447	{
4409	int index;	4448	int index = ivalue_unchecked (cadr (args));
4410		4449
4411	if (is_immutable (x))	4450	if (is_immutable (x))
4412	Error_1 ("vector-set!: unable to alter immutable vector:", x);	4451	Error_1 ("vector-set!: unable to alter immutable vector:", x);
4413
4414	index = ivalue (cadr (args));
4415		4452
4416	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)	4453	if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4417	Error_1 ("vector-set!: out of bounds:", cadr (args));	4454	Error_1 ("vector-set!: out of bounds:", cadr (args));
4418		4455
4419	set_vector_elem (x, index, caddr (args));	4456	set_vector_elem (x, index, caddr (args));
4420	s_return (x);	4457	s_return (x);
4421	}	4458	}
4422	}	4459	}
4423		4460
4424	abort ();	4461	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	}	4462	}
4480		4463
4481	static int	4464	static int
4482	opexe_2 (SCHEME_P_ enum scheme_opcodes op)	4465	opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4483	{	4466	{
…		…
4529	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;	4512	case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4530	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */	4513	case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4531	case OP_CHARP: /* char? */ r = is_character (a) ; break;	4514	case OP_CHARP: /* char? */ r = is_character (a) ; break;
4532		4515
4533	#if USE_CHAR_CLASSIFIERS	4516	#if USE_CHAR_CLASSIFIERS
4534	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue (a)); break;	4517	case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4535	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue (a)); break;	4518	case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4536	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue (a)); break;	4519	case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
4537	case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue (a)); break;	4520	case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break;
4538	case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue (a)); break;	4521	case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break;
4539	#endif	4522	#endif
4540		4523
4541	#if USE_PORTS	4524	#if USE_PORTS
4542	case OP_PORTP: /* port? */ r = is_port (a) ; break;	4525	case OP_PORTP: /* port? */ r = is_port (a) ; break;
4543	case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;	4526	case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
…		…
4726		4709
4727	case OP_QUIT: /* quit */	4710	case OP_QUIT: /* quit */
4728	if (is_pair (args))	4711	if (is_pair (args))
4729	SCHEME_V->retcode = ivalue (a);	4712	SCHEME_V->retcode = ivalue (a);
4730		4713
		4714	exit(0);//D
4731	return -1;	4715	return -1;
4732		4716
4733	case OP_GC: /* gc */	4717	case OP_GC: /* gc */
4734	gc (SCHEME_A_ NIL, NIL);	4718	gc (SCHEME_A_ NIL, NIL);
4735	s_return (S_T);	4719	s_return (S_T);
…		…
4744		4728
4745	case OP_NEWSEGMENT: /* new-segment */	4729	case OP_NEWSEGMENT: /* new-segment */
4746	if (!is_pair (args) || !is_number (a))	4730	if (!is_pair (args) || !is_number (a))
4747	Error_0 ("new-segment: argument must be a number");	4731	Error_0 ("new-segment: argument must be a number");
4748		4732
4749	alloc_cellseg (SCHEME_A_ (int)ivalue (a));	4733	alloc_cellseg (SCHEME_A_ ivalue (a));
4750		4734
4751	s_return (S_T);	4735	s_return (S_T);
4752		4736
4753	case OP_OBLIST: /* oblist */	4737	case OP_OBLIST: /* oblist */
4754	s_return (oblist_all_symbols (SCHEME_A));	4738	s_return (oblist_all_symbols (SCHEME_A));
…		…
4783	break;	4767	break;
4784	}	4768	}
4785		4769
4786	p = port_from_filename (SCHEME_A_ strvalue (a), prop);	4770	p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4787		4771
4788	if (p == NIL)	4772	s_return (p == NIL ? S_F : p);
4789	s_return (S_F);
4790
4791	s_return (p);
4792	}	4773	}
4793		4774
4794	# if USE_STRING_PORTS	4775	# if USE_STRING_PORTS
4795		4776
4796	case OP_OPEN_INSTRING: /* open-input-string */	4777	case OP_OPEN_INSTRING: /* open-input-string */
…		…
4811	}	4792	}
4812		4793
4813	p = port_from_string (SCHEME_A_ strvalue (a),	4794	p = port_from_string (SCHEME_A_ strvalue (a),
4814	strvalue (a) + strlength (a), prop);	4795	strvalue (a) + strlength (a), prop);
4815		4796
4816	if (p == NIL)	4797	s_return (p == NIL ? S_F : p);
4817	s_return (S_F);
4818
4819	s_return (p);
4820	}	4798	}
4821		4799
4822	case OP_OPEN_OUTSTRING: /* open-output-string */	4800	case OP_OPEN_OUTSTRING: /* open-output-string */
4823	{	4801	{
4824	pointer p;	4802	pointer p;
4825		4803
4826	if (a == NIL)	4804	if (a == NIL)
4827	{
4828	p = port_from_scratch (SCHEME_A);	4805	p = port_from_scratch (SCHEME_A);
4829
4830	if (p == NIL)
4831	s_return (S_F);
4832	}
4833	else	4806	else
4834	{
4835	p = port_from_string (SCHEME_A_ strvalue (a),	4807	p = port_from_string (SCHEME_A_ strvalue (a),
4836	strvalue (a) + strlength (a), port_output);	4808	strvalue (a) + strlength (a), port_output);
4837		4809
4838	if (p == NIL)	4810	s_return (p == NIL ? S_F : p);
4839	s_return (S_F);
4840	}
4841
4842	s_return (p);
4843	}	4811	}
4844		4812
4845	case OP_GET_OUTSTRING: /* get-output-string */	4813	case OP_GET_OUTSTRING: /* get-output-string */
4846	{	4814	{
4847	port *p;	4815	port *p;
…		…
4886	case OP_CURR_ENV: /* current-environment */	4854	case OP_CURR_ENV: /* current-environment */
4887	s_return (SCHEME_V->envir);	4855	s_return (SCHEME_V->envir);
4888		4856
4889	}	4857	}
4890		4858
4891	abort ();	4859	if (USE_ERROR_CHECKING) abort ();
4892	}	4860	}
4893		4861
4894	static int	4862	static int
4895	opexe_5 (SCHEME_P_ enum scheme_opcodes op)	4863	opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4896	{	4864	{
…		…
5229	s_goto (OP_P0LIST);	5197	s_goto (OP_P0LIST);
5230	}	5198	}
5231	}	5199	}
5232	}	5200	}
5233		5201
5234	abort ();	5202	if (USE_ERROR_CHECKING) abort ();
5235	}	5203	}
5236		5204
5237	static int	5205	static int
5238	opexe_6 (SCHEME_P_ enum scheme_opcodes op)	5206	opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5239	{	5207	{
…		…
5292		5260
5293	case OP_MACROP: /* macro? */	5261	case OP_MACROP: /* macro? */
5294	s_retbool (is_macro (a));	5262	s_retbool (is_macro (a));
5295	}	5263	}
5296		5264
5297	abort ();	5265	if (USE_ERROR_CHECKING) abort ();
5298	}	5266	}
5299		5267
5300	/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */	5268	/* 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);	5269	typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5302		5270
5303	typedef int (*test_predicate)(pointer);	5271	typedef int (*test_predicate)(pointer);
5304	static int	5272	static int
5305	is_any (pointer p)	5273	tst_any (pointer p)
5306	{	5274	{
5307	return 1;	5275	return 1;
5308	}	5276	}
5309		5277
5310	static int	5278	static int
5311	is_nonneg (pointer p)	5279	tst_inonneg (pointer p)
5312	{	5280	{
5313	return ivalue (p) >= 0 && is_integer (p);	5281	return is_integer (p) && ivalue_unchecked (p) >= 0;
5314	}	5282	}
5315		5283
5316	static int	5284	static int
5317	tst_is_list (pointer p)	5285	tst_is_list (SCHEME_P_ pointer p)
5318	{	5286	{
5319	return p == NIL || is_pair (p);	5287	return p == NIL || is_pair (p);
5320	}	5288	}
5321		5289
5322	/* Correspond carefully with following defines! */	5290	/* Correspond carefully with following defines! */
5323	static struct	5291	static struct
5324	{	5292	{
5325	test_predicate fct;	5293	test_predicate fct;
5326	const char *kind;	5294	const char *kind;
5327	} tests[] =	5295	} tests[] = {
5328	{
5329	{ is_any, 0 },	5296	{ tst_any , 0 },
5330	{ is_string, "string" },	5297	{ is_string , "string" },
5331	{ is_symbol, "symbol" },	5298	{ is_symbol , "symbol" },
5332	{ is_port, "port" },	5299	{ is_port , "port" },
5333	{ is_inport, "input port" },	5300	{ is_inport , "input port" },
5334	{ is_outport, "output port" },	5301	{ is_outport , "output port" },
5335	{ is_environment, "environment" },	5302	{ is_environment, "environment" },
5336	{ is_pair, "pair" },	5303	{ is_pair , "pair" },
5337	{ tst_is_list, "pair or '()" },	5304	{ 0 , "pair or '()" },
5338	{ is_character, "character" },	5305	{ is_character , "character" },
5339	{ is_vector, "vector" },	5306	{ is_vector , "vector" },
5340	{ is_number, "number" },	5307	{ is_number , "number" },
5341	{ is_integer, "integer" },	5308	{ is_integer , "integer" },
5342	{ is_nonneg, "non-negative integer" }	5309	{ tst_inonneg , "non-negative integer" }
5343	};	5310	};
5344		5311
5345	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */	5312	#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5346	#define TST_ANY "\001"	5313	#define TST_ANY "\001"
5347	#define TST_STRING "\002"	5314	#define TST_STRING "\002"
…		…
5388	typedef struct	5355	typedef struct
5389	{	5356	{
5390	uint8_t func;	5357	uint8_t func;
5391	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */	5358	/*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
5392	uint8_t builtin;	5359	uint8_t builtin;
		5360	#if USE_ERROR_CHECKING
5393	uint8_t min_arity;	5361	uint8_t min_arity;
5394	uint8_t max_arity;	5362	uint8_t max_arity;
5395	char arg_tests_encoding[3];	5363	char arg_tests_encoding[3];
		5364	#endif
5396	} op_code_info;	5365	} op_code_info;
5397		5366
5398	static const op_code_info dispatch_table[] = {	5367	static const op_code_info dispatch_table[] = {
		5368	#if USE_ERROR_CHECKING
5399	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },	5369	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
		5370	#else
		5371	#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 },
		5372	#endif
5400	#include "opdefines.h"	5373	#include "opdefines.h"
5401	#undef OP_DEF	5374	#undef OP_DEF
5402	{0}	5375	{0}
5403	};	5376	};
5404		5377
5405	/* kernel of this interpreter */	5378	/* kernel of this interpreter */
5406	static void	5379	static void ecb_hot
5407	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)	5380	Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5408	{	5381	{
5409	SCHEME_V->op = op;	5382	SCHEME_V->op = op;
5410		5383
5411	for (;;)	5384	for (;;)
…		…
5446	{	5419	{
5447	pointer arg = car (arglist);	5420	pointer arg = car (arglist);
5448		5421
5449	j = t[0];	5422	j = t[0];
5450		5423
		5424	/*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */
		5425	if (j == TST_LIST[0])
		5426	{
		5427	if (!tst_is_list (SCHEME_A_ arg))
		5428	break;
		5429	}
		5430	else
		5431	{
5451	if (!tests[j - 1].fct (arg))	5432	if (!tests[j - 1].fct (arg))
5452	break;	5433	break;
		5434	}
5453		5435
5454	if (t[1]) /* last test is replicated as necessary */	5436	if (t[1]) /* last test is replicated as necessary */
5455	t++;	5437	t++;
5456		5438
5457	arglist = cdr (arglist);	5439	arglist = cdr (arglist);
…		…
5514	mk_proc (SCHEME_P_ enum scheme_opcodes op)	5496	mk_proc (SCHEME_P_ enum scheme_opcodes op)
5515	{	5497	{
5516	pointer y = get_cell (SCHEME_A_ NIL, NIL);	5498	pointer y = get_cell (SCHEME_A_ NIL, NIL);
5517	set_typeflag (y, (T_PROC | T_ATOM));	5499	set_typeflag (y, (T_PROC | T_ATOM));
5518	ivalue_unchecked (y) = op;	5500	ivalue_unchecked (y) = op;
5519	set_num_integer (y);
5520	return y;	5501	return y;
5521	}	5502	}
5522		5503
5523	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */	5504	/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5524	static int	5505	static int
…		…
5589	return OP_C0STREAM; /* cons-stream */	5570	return OP_C0STREAM; /* cons-stream */
5590	}	5571	}
5591	}	5572	}
5592		5573
5593	#if USE_MULTIPLICITY	5574	#if USE_MULTIPLICITY
5594	scheme *	5575	ecb_cold scheme *
5595	scheme_init_new ()	5576	scheme_init_new ()
5596	{	5577	{
5597	scheme *sc = malloc (sizeof (scheme));	5578	scheme *sc = malloc (sizeof (scheme));
5598		5579
5599	if (!scheme_init (SCHEME_A))	5580	if (!scheme_init (SCHEME_A))
…		…
5604	else	5585	else
5605	return sc;	5586	return sc;
5606	}	5587	}
5607	#endif	5588	#endif
5608		5589
5609	int	5590	ecb_cold int
5610	scheme_init (SCHEME_P)	5591	scheme_init (SCHEME_P)
5611	{	5592	{
5612	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);	5593	int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5613	pointer x;	5594	pointer x;
5614		5595
…		…
5739	scheme_set_external_data (SCHEME_P_ void *p)	5720	scheme_set_external_data (SCHEME_P_ void *p)
5740	{	5721	{
5741	SCHEME_V->ext_data = p;	5722	SCHEME_V->ext_data = p;
5742	}	5723	}
5743		5724
5744	void	5725	ecb_cold void
5745	scheme_deinit (SCHEME_P)	5726	scheme_deinit (SCHEME_P)
5746	{	5727	{
5747	int i;	5728	int i;
5748		5729
5749	#if SHOW_ERROR_LINE	5730	#if SHOW_ERROR_LINE

Diff Legend

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