ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/microscheme/scheme.c
(Generate patch)

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.6 by root, Wed Nov 25 10:57:17 2015 UTC vs.
Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC

1 1/*
2/* T I N Y S C H E M E 1 . 4 1 2 * µscheme
3 *
4 * Copyright (C) 2015 Marc Alexander Lehmann <uscheme@schmorp.de>
5 * do as you want with this, attribution appreciated.
6 *
7 * Based opn tinyscheme-1.41 (original credits follow)
3 * Dimitrios Souflis (dsouflis@acm.org) 8 * Dimitrios Souflis (dsouflis@acm.org)
4 * Based on MiniScheme (original credits follow) 9 * Based on MiniScheme (original credits follow)
5 * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) 10 * (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
6 * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp 11 * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
7 * (MINISCM) This version has been modified by R.C. Secrist. 12 * (MINISCM) This version has been modified by R.C. Secrist.
… …
11 * (MINISCM) This is a revised and modified version by Akira KIDA. 16 * (MINISCM) This is a revised and modified version by Akira KIDA.
12 * (MINISCM) current version is 0.85k4 (15 May 1994) 17 * (MINISCM) current version is 0.85k4 (15 May 1994)
13 * 18 *
14 */ 19 */
15 20
21#define EXPERIMENT 1
22
23#if 1
16#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ 24#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
17#include "malloc.c" 25#include "malloc.c"
26#endif
18 27
19#define SCHEME_SOURCE 28#define SCHEME_SOURCE
20#include "scheme-private.h" 29#include "scheme-private.h"
21#ifndef WIN32 30#ifndef WIN32
22# include <unistd.h> 31# include <unistd.h>
23#endif 32#endif
24#if USE_MATH 33#if USE_MATH
25# include <math.h> 34# include <math.h>
26#endif 35#endif
27 36
37#include "ecb.h"
38
28#include <sys/types.h> 39#include <sys/types.h>
29#include <sys/stat.h> 40#include <sys/stat.h>
30#include <fcntl.h> 41#include <fcntl.h>
31 42
43#if !USE_ERROR_CHECKING
44# define NDEBUG
45#endif
46
47#include <assert.h>
48#include <stdlib.h>
32#include <string.h> 49#include <string.h>
33#include <stdlib.h>
34 50
35#include <limits.h> 51#include <limits.h>
36#include <inttypes.h> 52#include <inttypes.h>
37#include <float.h> 53#include <float.h>
38//#include <ctype.h> 54//#include <ctype.h>
55
56#if '1' != '0' + 1 \
57 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
58 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
59 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
60 || 'f' != 'a' + 5
61# error "execution character set digits not consecutive"
62#endif
39 63
40enum { 64enum {
41 TOK_EOF, 65 TOK_EOF,
42 TOK_LPAREN, 66 TOK_LPAREN,
43 TOK_RPAREN, 67 TOK_RPAREN,
44 TOK_DOT, 68 TOK_DOT,
45 TOK_ATOM, 69 TOK_ATOM,
70 TOK_DOTATOM, /* atom name starting with '.' */
71 TOK_STRATOM, /* atom name enclosed in | */
46 TOK_QUOTE, 72 TOK_QUOTE,
47 TOK_DQUOTE, 73 TOK_DQUOTE,
48 TOK_BQUOTE, 74 TOK_BQUOTE,
49 TOK_COMMA, 75 TOK_COMMA,
50 TOK_ATMARK, 76 TOK_ATMARK,
… …
52 TOK_SHARP_CONST, 78 TOK_SHARP_CONST,
53 TOK_VEC 79 TOK_VEC
54}; 80};
55 81
56#define BACKQUOTE '`' 82#define BACKQUOTE '`'
57#define DELIMITERS "()\";\f\t\v\n\r " 83#define WHITESPACE " \t\r\n\v\f"
84#define DELIMITERS "()\";" WHITESPACE
58 85
59#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 86#define NIL POINTER (&SCHEME_V->xNIL)
60#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 87#define S_T POINTER (&SCHEME_V->xT)
61#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 88#define S_F POINTER (&SCHEME_V->xF)
62#define S_SINK (&SCHEME_V->xsink) 89#define S_SINK POINTER (&SCHEME_V->xsink)
63#define S_EOF (&SCHEME_V->xEOF_OBJ) 90#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
64 91
65#if !USE_MULTIPLICITY 92#if !USE_MULTIPLICITY
66static scheme sc; 93static scheme sc;
67#endif 94#endif
68 95
69static void 96ecb_cold static void
70xbase (char *s, long n, int base) 97xbase (char *s, long n, int base)
71{ 98{
72 if (n < 0) 99 if (n < 0)
73 { 100 {
74 *s++ = '-'; 101 *s++ = '-';
… …
76 } 103 }
77 104
78 char *p = s; 105 char *p = s;
79 106
80 do { 107 do {
81 *p++ = '0' + n % base; 108 *p++ = "0123456789abcdef"[n % base];
82 n /= base; 109 n /= base;
83 } while (n); 110 } while (n);
84 111
85 *p-- = 0; 112 *p-- = 0;
86 113
… …
89 char x = *s; *s = *p; *p = x; 116 char x = *s; *s = *p; *p = x;
90 --p; ++s; 117 --p; ++s;
91 } 118 }
92} 119}
93 120
94static void 121ecb_cold static void
95xnum (char *s, long n) 122xnum (char *s, long n)
96{ 123{
97 xbase (s, n, 10); 124 xbase (s, n, 10);
98} 125}
99 126
100static void 127ecb_cold static void
101xwrstr (const char *s) 128putnum (SCHEME_P_ long n)
102{
103 write (1, s, strlen (s));
104}
105
106static void
107xwrnum (long n)
108{ 129{
109 char buf[64]; 130 char buf[64];
110 131
111 xnum (buf, n); 132 xnum (buf, n);
112 xwrstr (buf); 133 putstr (SCHEME_A_ buf);
113} 134}
114 135
115static char 136ecb_cold static char
116xtoupper (char c) 137xtoupper (char c)
117{ 138{
118 if (c >= 'a' && c <= 'z') 139 if (c >= 'a' && c <= 'z')
119 c -= 'a' - 'A'; 140 c -= 'a' - 'A';
120 141
121 return c; 142 return c;
122} 143}
123 144
124static char 145ecb_cold static char
125xtolower (char c) 146xtolower (char c)
126{ 147{
127 if (c >= 'A' && c <= 'Z') 148 if (c >= 'A' && c <= 'Z')
128 c += 'a' - 'A'; 149 c += 'a' - 'A';
129 150
130 return c; 151 return c;
131} 152}
132 153
133#if USE_STRLWR 154ecb_cold static int
155xisdigit (char c)
156{
157 return c >= '0' && c <= '9';
158}
159
160#define toupper(c) xtoupper (c)
161#define tolower(c) xtolower (c)
162#define isdigit(c) xisdigit (c)
163
164#if USE_IGNORECASE
134static const char * 165ecb_cold static const char *
135strlwr (char *s) 166xstrlwr (char *s)
136{ 167{
137 const char *p = s; 168 const char *p = s;
138 169
139 while (*s) 170 while (*s)
140 { 171 {
… …
142 s++; 173 s++;
143 } 174 }
144 175
145 return p; 176 return p;
146} 177}
147#endif
148 178
179#define stricmp(a,b) strcasecmp (a, b)
180#define strlwr(s) xstrlwr (s)
181
182#else
149#define stricmp(a,b) strcmp (a, b) 183# define stricmp(a,b) strcmp (a, b)
150#define strlwr(s) (s) 184# define strlwr(s) (s)
151#define toupper(c) xtoupper(c) 185#endif
152#define tolower(c) xtolower(c)
153 186
154#ifndef prompt 187#ifndef prompt
155# define prompt "ts> " 188# define prompt "ts> "
156#endif 189#endif
157 190
158#ifndef InitFile 191#ifndef InitFile
159# define InitFile "init.scm" 192# define InitFile "init.scm"
160#endif 193#endif
161 194
162#ifndef FIRST_CELLSEGS
163# define FIRST_CELLSEGS 3
164#endif
165
166enum scheme_types 195enum scheme_types
167{ 196{
197 T_INTEGER,
198 T_CHARACTER,
168 T_FREE, 199 T_REAL,
169 T_STRING, 200 T_STRING,
170 T_NUMBER,
171 T_SYMBOL, 201 T_SYMBOL,
172 T_PROC, 202 T_PROC,
173 T_PAIR, 203 T_PAIR, /* also used for free cells */
174 T_CLOSURE, 204 T_CLOSURE,
205 T_MACRO,
175 T_CONTINUATION, 206 T_CONTINUATION,
176 T_FOREIGN, 207 T_FOREIGN,
177 T_CHARACTER,
178 T_PORT, 208 T_PORT,
179 T_VECTOR, 209 T_VECTOR,
180 T_MACRO,
181 T_PROMISE, 210 T_PROMISE,
182 T_ENVIRONMENT, 211 T_ENVIRONMENT,
183 /* one more... */ 212 /* one more... */
184 T_NUM_SYSTEM_TYPES 213 T_NUM_SYSTEM_TYPES
185}; 214};
… …
188#define T_SYNTAX 0x0010 217#define T_SYNTAX 0x0010
189#define T_IMMUTABLE 0x0020 218#define T_IMMUTABLE 0x0020
190#define T_ATOM 0x0040 /* only for gc */ 219#define T_ATOM 0x0040 /* only for gc */
191#define T_MARK 0x0080 /* only for gc */ 220#define T_MARK 0x0080 /* only for gc */
192 221
193static num num_add (num a, num b); 222/* num, for generic arithmetic */
194static num num_mul (num a, num b); 223struct num
195static num num_div (num a, num b); 224{
225 IVALUE ivalue;
226#if USE_REAL
227 RVALUE rvalue;
228 char is_fixnum;
229#endif
230};
231
232#if USE_REAL
233# define num_is_fixnum(n) (n).is_fixnum
234# define num_set_fixnum(n,f) (n).is_fixnum = (f)
235# define num_ivalue(n) (n).ivalue
236# define num_rvalue(n) (n).rvalue
237# define num_set_ivalue(n,i) (n).rvalue = (n).ivalue = (i)
238# define num_set_rvalue(n,r) (n).rvalue = (r)
239#else
240# define num_is_fixnum(n) 1
241# define num_set_fixnum(n,f) 0
242# define num_ivalue(n) (n).ivalue
243# define num_rvalue(n) (n).ivalue
244# define num_set_ivalue(n,i) (n).ivalue = (i)
245# define num_set_rvalue(n,r) (n).ivalue = (r)
246#endif
247
248enum num_op { NUM_ADD, NUM_SUB, NUM_MUL, NUM_INTDIV };
249
250static num num_op (enum num_op op, num a, num b);
196static num num_intdiv (num a, num b); 251static num num_intdiv (num a, num b);
197static num num_sub (num a, num b);
198static num num_rem (num a, num b); 252static num num_rem (num a, num b);
199static num num_mod (num a, num b); 253static num num_mod (num a, num b);
200static int num_eq (num a, num b);
201static int num_gt (num a, num b);
202static int num_ge (num a, num b);
203static int num_lt (num a, num b);
204static int num_le (num a, num b);
205 254
206#if USE_MATH
207static double round_per_R5RS (double x);
208#endif
209static int is_zero_rvalue (RVALUE x); 255static int is_zero_rvalue (RVALUE x);
210
211static INLINE int
212num_is_integer (pointer p)
213{
214 return num_is_fixnum (p->object.number);
215}
216 256
217static num num_zero; 257static num num_zero;
218static num num_one; 258static num num_one;
219 259
260/* convert "pointer" to cell* / cell* to pointer */
261#define CELL(p) ((struct cell *)(p) + 0)
262#define POINTER(c) ((void *)((c) - 0))
263
220/* macros for cell operations */ 264/* macros for cell operations */
221#define typeflag(p) ((p)->flag + 0) 265#define typeflag(p) (CELL(p)->flag + 0)
222#define set_typeflag(p,v) ((p)->flag = (v)) 266#define set_typeflag(p,v) (CELL(p)->flag = (v))
223#define type(p) (typeflag (p) & T_MASKTYPE) 267#define type(p) (typeflag (p) & T_MASKTYPE)
224 268
225INTERFACE INLINE int 269INTERFACE int
226is_string (pointer p) 270is_string (pointer p)
227{ 271{
228 return type (p) == T_STRING; 272 return type (p) == T_STRING;
229} 273}
230 274
231#define strvalue(p) ((p)->object.string.svalue) 275#define strvalue(p) (CELL(p)->object.string.svalue)
232#define strlength(p) ((p)->object.string.length) 276#define strlength(p) (CELL(p)->object.string.length)
233 277
234INTERFACE int is_list (SCHEME_P_ pointer p);
235INTERFACE INLINE int 278INTERFACE int
236is_vector (pointer p) 279is_vector (pointer p)
237{ 280{
238 return type (p) == T_VECTOR; 281 return type (p) == T_VECTOR;
239} 282}
240 283
284#define vecvalue(p) (CELL(p)->object.vector.vvalue)
285#define veclength(p) (CELL(p)->object.vector.length)
241INTERFACE void fill_vector (pointer vec, pointer obj); 286INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
242INTERFACE uint32_t vector_length (pointer vec);
243INTERFACE pointer vector_elem (pointer vec, uint32_t ielem); 287INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
244INTERFACE void set_vector_elem (pointer vec, uint32_t ielem, pointer a); 288INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
245 289
246INTERFACE uint32_t 290INTERFACE int
247vector_length (pointer vec) 291is_integer (pointer p)
248{ 292{
249 return vec->object.vector.length; 293 return type (p) == T_INTEGER;
250} 294}
251 295
296/* not the same as in scheme, where integers are (correctly :) reals */
252INTERFACE INLINE int 297INTERFACE int
298is_real (pointer p)
299{
300 return type (p) == T_REAL;
301}
302
303INTERFACE int
253is_number (pointer p) 304is_number (pointer p)
254{ 305{
255 return type (p) == T_NUMBER; 306 return is_integer (p) || is_real (p);
256} 307}
257 308
258INTERFACE INLINE int 309INTERFACE int
259is_integer (pointer p)
260{
261 if (!is_number (p))
262 return 0;
263
264 if (num_is_integer (p) || ivalue (p) == rvalue (p))
265 return 1;
266
267 return 0;
268}
269
270INTERFACE INLINE int
271is_real (pointer p)
272{
273 return is_number (p) && !num_is_fixnum (p->object.number);
274}
275
276INTERFACE INLINE int
277is_character (pointer p) 310is_character (pointer p)
278{ 311{
279 return type (p) == T_CHARACTER; 312 return type (p) == T_CHARACTER;
280} 313}
281 314
282INTERFACE INLINE char * 315INTERFACE char *
283string_value (pointer p) 316string_value (pointer p)
284{ 317{
285 return strvalue (p); 318 return strvalue (p);
286} 319}
287 320
288INLINE num
289nvalue (pointer p)
290{
291 return (p)->object.number;
292}
293
294static IVALUE
295num_get_ivalue (const num n)
296{
297 return num_is_fixnum (n) ? num_ivalue (n) : (IVALUE)num_rvalue (n);
298}
299
300static RVALUE
301num_get_rvalue (const num n)
302{
303 return num_is_fixnum (n) ? (RVALUE)num_ivalue (n) : num_rvalue (n);
304}
305
306INTERFACE IVALUE
307ivalue (pointer p)
308{
309 return num_get_ivalue (p->object.number);
310}
311
312INTERFACE RVALUE
313rvalue (pointer p)
314{
315 return num_get_rvalue (p->object.number);
316}
317
318#define ivalue_unchecked(p) ((p)->object.number.value.ivalue) 321#define ivalue_unchecked(p) CELL(p)->object.ivalue
319#if USE_FLOAT 322#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
323
324#if USE_REAL
320# define rvalue_unchecked(p) ((p)->object.number.value.rvalue) 325#define rvalue_unchecked(p) CELL(p)->object.rvalue
321# define set_num_integer(p) (p)->object.number.is_fixnum=1; 326#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
322# define set_num_real(p) (p)->object.number.is_fixnum=0;
323#else 327#else
324# define rvalue_unchecked(p) ((p)->object.number.value.ivalue) 328#define rvalue_unchecked(p) CELL(p)->object.ivalue
325# define set_num_integer(p) 0 329#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
326# define set_num_real(p) 0
327#endif 330#endif
331
328INTERFACE long 332INTERFACE long
329charvalue (pointer p) 333charvalue (pointer p)
330{ 334{
331 return ivalue_unchecked (p); 335 return ivalue_unchecked (p);
332} 336}
333 337
338#define port(p) CELL(p)->object.port
339#define set_port(p,v) port(p) = (v)
334INTERFACE INLINE int 340INTERFACE int
335is_port (pointer p) 341is_port (pointer p)
336{ 342{
337 return type (p) == T_PORT; 343 return type (p) == T_PORT;
338} 344}
339 345
340INTERFACE INLINE int 346INTERFACE int
341is_inport (pointer p) 347is_inport (pointer p)
342{ 348{
343 return is_port (p) && p->object.port->kind & port_input; 349 return is_port (p) && port (p)->kind & port_input;
344} 350}
345 351
346INTERFACE INLINE int 352INTERFACE int
347is_outport (pointer p) 353is_outport (pointer p)
348{ 354{
349 return is_port (p) && p->object.port->kind & port_output; 355 return is_port (p) && port (p)->kind & port_output;
350} 356}
351 357
352INTERFACE INLINE int 358INTERFACE int
353is_pair (pointer p) 359is_pair (pointer p)
354{ 360{
355 return type (p) == T_PAIR; 361 return type (p) == T_PAIR;
356} 362}
357 363
358#define car(p) ((p)->object.cons.car + 0) 364#define car(p) (POINTER (CELL(p)->object.cons.car))
359#define cdr(p) ((p)->object.cons.cdr) /* find_consecutive_cells uses &cdr */ 365#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
360 366
361#define caar(p) car (car (p)) 367static pointer caar (pointer p) { return car (car (p)); }
362#define cadr(p) car (cdr (p)) 368static pointer cadr (pointer p) { return car (cdr (p)); }
363#define cdar(p) cdr (car (p)) 369static pointer cdar (pointer p) { return cdr (car (p)); }
364#define cddr(p) cdr (cdr (p)) 370static pointer cddr (pointer p) { return cdr (cdr (p)); }
365 371
366#define cadar(p) car (cdr (car (p))) 372static pointer cadar (pointer p) { return car (cdr (car (p))); }
367#define caddr(p) car (cdr (cdr (p))) 373static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
368#define cdaar(p) cdr (car (car (p))) 374static pointer cdaar (pointer p) { return cdr (car (car (p))); }
369 375
370INTERFACE void 376INTERFACE void
371set_car (pointer p, pointer q) 377set_car (pointer p, pointer q)
372{ 378{
373 p->object.cons.car = q; 379 CELL(p)->object.cons.car = CELL (q);
374} 380}
375 381
376INTERFACE void 382INTERFACE void
377set_cdr (pointer p, pointer q) 383set_cdr (pointer p, pointer q)
378{ 384{
379 p->object.cons.cdr = q; 385 CELL(p)->object.cons.cdr = CELL (q);
380} 386}
381 387
382INTERFACE pointer 388INTERFACE pointer
383pair_car (pointer p) 389pair_car (pointer p)
384{ 390{
… …
389pair_cdr (pointer p) 395pair_cdr (pointer p)
390{ 396{
391 return cdr (p); 397 return cdr (p);
392} 398}
393 399
394INTERFACE INLINE int 400INTERFACE int
395is_symbol (pointer p) 401is_symbol (pointer p)
396{ 402{
397 return type (p) == T_SYMBOL; 403 return type (p) == T_SYMBOL;
398} 404}
399 405
400INTERFACE INLINE char * 406INTERFACE char *
401symname (pointer p) 407symname (pointer p)
402{ 408{
403 return strvalue (car (p)); 409 return strvalue (p);
404} 410}
405 411
406#if USE_PLIST 412#if USE_PLIST
413#error plists are broken because symbols are no longer pairs
414#define symprop(p) cdr(p)
407SCHEME_EXPORT INLINE int 415SCHEME_EXPORT int
408hasprop (pointer p) 416hasprop (pointer p)
409{ 417{
410 return typeflag (p) & T_SYMBOL; 418 return typeflag (p) & T_SYMBOL;
411} 419}
412
413# define symprop(p) cdr(p)
414#endif 420#endif
415 421
416INTERFACE INLINE int 422INTERFACE int
417is_syntax (pointer p) 423is_syntax (pointer p)
418{ 424{
419 return typeflag (p) & T_SYNTAX; 425 return typeflag (p) & T_SYNTAX;
420} 426}
421 427
422INTERFACE INLINE int 428INTERFACE int
423is_proc (pointer p) 429is_proc (pointer p)
424{ 430{
425 return type (p) == T_PROC; 431 return type (p) == T_PROC;
426} 432}
427 433
428INTERFACE INLINE int 434INTERFACE int
429is_foreign (pointer p) 435is_foreign (pointer p)
430{ 436{
431 return type (p) == T_FOREIGN; 437 return type (p) == T_FOREIGN;
432} 438}
433 439
434INTERFACE INLINE char * 440INTERFACE char *
435syntaxname (pointer p) 441syntaxname (pointer p)
436{ 442{
437 return strvalue (car (p)); 443 return strvalue (p);
438} 444}
439 445
440#define procnum(p) ivalue (p) 446#define procnum(p) ivalue_unchecked (p)
441static const char *procname (pointer x); 447static const char *procname (pointer x);
442 448
443INTERFACE INLINE int 449INTERFACE int
444is_closure (pointer p) 450is_closure (pointer p)
445{ 451{
446 return type (p) == T_CLOSURE; 452 return type (p) == T_CLOSURE;
447} 453}
448 454
449INTERFACE INLINE int 455INTERFACE int
450is_macro (pointer p) 456is_macro (pointer p)
451{ 457{
452 return type (p) == T_MACRO; 458 return type (p) == T_MACRO;
453} 459}
454 460
455INTERFACE INLINE pointer 461INTERFACE pointer
456closure_code (pointer p) 462closure_code (pointer p)
457{ 463{
458 return car (p); 464 return car (p);
459} 465}
460 466
461INTERFACE INLINE pointer 467INTERFACE pointer
462closure_env (pointer p) 468closure_env (pointer p)
463{ 469{
464 return cdr (p); 470 return cdr (p);
465} 471}
466 472
467INTERFACE INLINE int 473INTERFACE int
468is_continuation (pointer p) 474is_continuation (pointer p)
469{ 475{
470 return type (p) == T_CONTINUATION; 476 return type (p) == T_CONTINUATION;
471} 477}
472 478
473#define cont_dump(p) cdr (p) 479#define cont_dump(p) cdr (p)
474#define set_cont_dump(p,v) set_cdr ((p), (v)) 480#define set_cont_dump(p,v) set_cdr ((p), (v))
475 481
476/* To do: promise should be forced ONCE only */ 482/* To do: promise should be forced ONCE only */
477INTERFACE INLINE int 483INTERFACE int
478is_promise (pointer p) 484is_promise (pointer p)
479{ 485{
480 return type (p) == T_PROMISE; 486 return type (p) == T_PROMISE;
481} 487}
482 488
483INTERFACE INLINE int 489INTERFACE int
484is_environment (pointer p) 490is_environment (pointer p)
485{ 491{
486 return type (p) == T_ENVIRONMENT; 492 return type (p) == T_ENVIRONMENT;
487} 493}
488 494
489#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT) 495#define setenvironment(p) set_typeflag ((p), T_ENVIRONMENT)
490 496
491#define is_atom1(p) (TYPESET_ATOM & (1U << type (p)))
492#define is_atom(p) (typeflag (p) & T_ATOM) 497#define is_atom(p) (typeflag (p) & T_ATOM)
493#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 498#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
494#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) 499#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
495 500
496#define is_mark(p) (typeflag (p) & T_MARK) 501#define is_mark(p) (typeflag (p) & T_MARK)
497#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 502#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
498#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 503#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
499 504
500#if 0
501static int
502is_atom(pointer p)
503{
504 if (!is_atom1(p) != !is_atom2(p))
505 printf ("atoms disagree %x\n", typeflag(p));
506
507 return is_atom2(p);
508}
509#endif
510
511INTERFACE INLINE int 505INTERFACE int
512is_immutable (pointer p) 506is_immutable (pointer p)
513{ 507{
514 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 508 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
515} 509}
516 510
517INTERFACE INLINE void 511INTERFACE void
518setimmutable (pointer p) 512setimmutable (pointer p)
519{ 513{
520#if USE_ERROR_CHECKING 514#if USE_ERROR_CHECKING
521 set_typeflag (p, typeflag (p) | T_IMMUTABLE); 515 set_typeflag (p, typeflag (p) | T_IMMUTABLE);
522#endif 516#endif
523} 517}
524 518
519/* Result is:
520 proper list: length
521 circular list: -1
522 not even a pair: -2
523 dotted list: -2 minus length before dot
524*/
525ecb_hot INTERFACE int
526list_length (SCHEME_P_ pointer a)
527{
528 int i = 0;
529 pointer slow, fast;
530
531 slow = fast = a;
532
533 while (1)
534 {
535 if (fast == NIL)
536 return i;
537
538 if (!is_pair (fast))
539 return -2 - i;
540
541 fast = cdr (fast);
542 ++i;
543
544 if (fast == NIL)
545 return i;
546
547 if (!is_pair (fast))
548 return -2 - i;
549
550 ++i;
551 fast = cdr (fast);
552
553 /* Safe because we would have already returned if `fast'
554 encountered a non-pair. */
555 slow = cdr (slow);
556
557 if (fast == slow)
558 {
559 /* the fast pointer has looped back around and caught up
560 with the slow pointer, hence the structure is circular,
561 not of finite length, and therefore not a list */
562 return -1;
563 }
564 }
565}
566
567INTERFACE int
568is_list (SCHEME_P_ pointer a)
569{
570 return list_length (SCHEME_A_ a) >= 0;
571}
572
525#if USE_CHAR_CLASSIFIERS 573#if USE_CHAR_CLASSIFIERS
526static INLINE int 574ecb_inline int
527Cisalpha (int c) 575Cisalpha (int c)
528{ 576{
529 return isascii (c) && isalpha (c); 577 return isascii (c) && isalpha (c);
530} 578}
531 579
532static INLINE int 580ecb_inline int
533Cisdigit (int c) 581Cisdigit (int c)
534{ 582{
535 return isascii (c) && isdigit (c); 583 return isascii (c) && isdigit (c);
536} 584}
537 585
538static INLINE int 586ecb_inline int
539Cisspace (int c) 587Cisspace (int c)
540{ 588{
541 return isascii (c) && isspace (c); 589 return isascii (c) && isspace (c);
542} 590}
543 591
544static INLINE int 592ecb_inline int
545Cisupper (int c) 593Cisupper (int c)
546{ 594{
547 return isascii (c) && isupper (c); 595 return isascii (c) && isupper (c);
548} 596}
549 597
550static INLINE int 598ecb_inline int
551Cislower (int c) 599Cislower (int c)
552{ 600{
553 return isascii (c) && islower (c); 601 return isascii (c) && islower (c);
554} 602}
555#endif 603#endif
… …
588 "gs", 636 "gs",
589 "rs", 637 "rs",
590 "us" 638 "us"
591}; 639};
592 640
593static int 641ecb_cold static int
594is_ascii_name (const char *name, int *pc) 642is_ascii_name (const char *name, int *pc)
595{ 643{
596 int i; 644 int i;
597 645
598 for (i = 0; i < 32; i++) 646 for (i = 0; i < 32; i++)
… …
616#endif 664#endif
617 665
618static int file_push (SCHEME_P_ const char *fname); 666static int file_push (SCHEME_P_ const char *fname);
619static void file_pop (SCHEME_P); 667static void file_pop (SCHEME_P);
620static int file_interactive (SCHEME_P); 668static int file_interactive (SCHEME_P);
621static INLINE int is_one_of (char *s, int c); 669ecb_inline int is_one_of (const char *s, int c);
622static int alloc_cellseg (SCHEME_P_ int n); 670static int alloc_cellseg (SCHEME_P);
623static long binary_decode (const char *s);
624static INLINE pointer get_cell (SCHEME_P_ pointer a, pointer b); 671ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
625static void finalize_cell (SCHEME_P_ pointer a); 672static void finalize_cell (SCHEME_P_ pointer a);
626static int count_consecutive_cells (pointer x, int needed); 673static int count_consecutive_cells (pointer x, int needed);
627static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 674static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
628static pointer mk_number (SCHEME_P_ const num n); 675static pointer mk_number (SCHEME_P_ const num n);
629static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 676static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
… …
644static void mark (pointer a); 691static void mark (pointer a);
645static void gc (SCHEME_P_ pointer a, pointer b); 692static void gc (SCHEME_P_ pointer a, pointer b);
646static int basic_inchar (port *pt); 693static int basic_inchar (port *pt);
647static int inchar (SCHEME_P); 694static int inchar (SCHEME_P);
648static void backchar (SCHEME_P_ int c); 695static void backchar (SCHEME_P_ int c);
649static char *readstr_upto (SCHEME_P_ char *delim); 696static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
650static pointer readstrexp (SCHEME_P); 697static pointer readstrexp (SCHEME_P_ char delim);
651static INLINE int skipspace (SCHEME_P); 698ecb_inline int skipspace (SCHEME_P);
652static int token (SCHEME_P); 699static int token (SCHEME_P);
653static void printslashstring (SCHEME_P_ char *s, int len); 700static void printslashstring (SCHEME_P_ char *s, int len);
654static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 701static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
655static void printatom (SCHEME_P_ pointer l, int f); 702static void printatom (SCHEME_P_ pointer l, int f);
656static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 703static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
660static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list); 707static pointer reverse_in_place (SCHEME_P_ pointer term, pointer list);
661static pointer revappend (SCHEME_P_ pointer a, pointer b); 708static pointer revappend (SCHEME_P_ pointer a, pointer b);
662static pointer ss_get_cont (SCHEME_P); 709static pointer ss_get_cont (SCHEME_P);
663static void ss_set_cont (SCHEME_P_ pointer cont); 710static void ss_set_cont (SCHEME_P_ pointer cont);
664static void dump_stack_mark (SCHEME_P); 711static void dump_stack_mark (SCHEME_P);
665static pointer opexe_0 (SCHEME_P_ enum scheme_opcodes op); 712static int opexe_0 (SCHEME_P_ enum scheme_opcodes op);
713static int opexe_1 (SCHEME_P_ enum scheme_opcodes op);
666static pointer opexe_2 (SCHEME_P_ enum scheme_opcodes op); 714static int opexe_2 (SCHEME_P_ enum scheme_opcodes op);
667static pointer opexe_3 (SCHEME_P_ enum scheme_opcodes op); 715static int opexe_3 (SCHEME_P_ enum scheme_opcodes op);
668static pointer opexe_4 (SCHEME_P_ enum scheme_opcodes op); 716static int opexe_4 (SCHEME_P_ enum scheme_opcodes op);
669static pointer opexe_5 (SCHEME_P_ enum scheme_opcodes op); 717static int opexe_5 (SCHEME_P_ enum scheme_opcodes op);
670static pointer opexe_6 (SCHEME_P_ enum scheme_opcodes op); 718static int opexe_6 (SCHEME_P_ enum scheme_opcodes op);
671static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op); 719static void Eval_Cycle (SCHEME_P_ enum scheme_opcodes op);
672static void assign_syntax (SCHEME_P_ const char *name); 720static void assign_syntax (SCHEME_P_ const char *name);
673static int syntaxnum (pointer p); 721static int syntaxnum (pointer p);
674static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name); 722static void assign_proc (SCHEME_P_ enum scheme_opcodes, const char *name);
675 723
724static IVALUE
725ivalue (pointer x)
726{
727 return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
728}
729
730static RVALUE
731rvalue (pointer x)
732{
733 return is_integer (x) ? ivalue_unchecked (x) : rvalue_unchecked (x);
734}
735
736INTERFACE num
737nvalue (pointer x)
738{
739 num n;
740
741 num_set_fixnum (n, is_integer (x));
742
743 if (num_is_fixnum (n))
744 num_set_ivalue (n, ivalue_unchecked (x));
745 else
746 num_set_rvalue (n, rvalue_unchecked (x));
747
748 return n;
749}
750
676static num 751static num
677num_add (num a, num b) 752num_op (enum num_op op, num a, num b)
678{ 753{
679 num ret; 754 num ret;
680 755
681 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 756 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
682 757
683 if (num_is_fixnum (ret)) 758 if (num_is_fixnum (ret))
684 num_set_ivalue (ret, num_get_ivalue (a) + num_get_ivalue (b)); 759 {
760 switch (op)
761 {
762 case NUM_ADD: a.ivalue += b.ivalue; break;
763 case NUM_SUB: a.ivalue -= b.ivalue; break;
764 case NUM_MUL: a.ivalue *= b.ivalue; break;
765 case NUM_INTDIV: a.ivalue /= b.ivalue; break;
766 }
767
768 num_set_ivalue (ret, a.ivalue);
769 }
770#if USE_REAL
685 else 771 else
686 num_set_rvalue (ret, num_get_rvalue (a) + num_get_rvalue (b)); 772 {
773 switch (op)
774 {
775 case NUM_ADD: a.rvalue += b.rvalue; break;
776 case NUM_SUB: a.rvalue -= b.rvalue; break;
777 case NUM_MUL: a.rvalue *= b.rvalue; break;
778 case NUM_INTDIV: a.rvalue /= b.rvalue; break;
779 }
687 780
688 return ret; 781 num_set_rvalue (ret, a.rvalue);
689} 782 }
690 783#endif
691static num
692num_mul (num a, num b)
693{
694 num ret;
695
696 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
697
698 if (num_is_fixnum (ret))
699 num_set_ivalue (ret, num_get_ivalue (a) * num_get_ivalue (b));
700 else
701 num_set_rvalue (ret, num_get_rvalue (a) * num_get_rvalue (b));
702 784
703 return ret; 785 return ret;
704} 786}
705 787
706static num 788static num
707num_div (num a, num b) 789num_div (num a, num b)
708{ 790{
709 num ret; 791 num ret;
710 792
711 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_get_ivalue (a) % num_get_ivalue (b) == 0); 793 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b) && num_ivalue (a) % num_ivalue (b) == 0);
712 794
713 if (num_is_fixnum (ret)) 795 if (num_is_fixnum (ret))
714 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b)); 796 num_set_ivalue (ret, num_ivalue (a) / num_ivalue (b));
715 else 797 else
716 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b)); 798 num_set_rvalue (ret, num_rvalue (a) / num_rvalue (b));
717
718 return ret;
719}
720
721static num
722num_intdiv (num a, num b)
723{
724 num ret;
725
726 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
727
728 if (num_is_fixnum (ret))
729 num_set_ivalue (ret, num_get_ivalue (a) / num_get_ivalue (b));
730 else
731 num_set_rvalue (ret, num_get_rvalue (a) / num_get_rvalue (b));
732
733 return ret;
734}
735
736static num
737num_sub (num a, num b)
738{
739 num ret;
740
741 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
742
743 if (num_is_fixnum (ret))
744 num_set_ivalue (ret, num_get_ivalue (a) - num_get_ivalue (b));
745 else
746 num_set_rvalue (ret, num_get_rvalue (a) - num_get_rvalue (b));
747 799
748 return ret; 800 return ret;
749} 801}
750 802
751static num 803static num
… …
753{ 805{
754 num ret; 806 num ret;
755 long e1, e2, res; 807 long e1, e2, res;
756 808
757 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 809 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
758 e1 = num_get_ivalue (a); 810 e1 = num_ivalue (a);
759 e2 = num_get_ivalue (b); 811 e2 = num_ivalue (b);
760 res = e1 % e2; 812 res = e1 % e2;
761 813
762 /* remainder should have same sign as second operand */ 814 /* remainder should have same sign as second operand */
763 if (res > 0) 815 if (res > 0)
764 { 816 {
… …
780{ 832{
781 num ret; 833 num ret;
782 long e1, e2, res; 834 long e1, e2, res;
783 835
784 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b)); 836 num_set_fixnum (ret, num_is_fixnum (a) && num_is_fixnum (b));
785 e1 = num_get_ivalue (a); 837 e1 = num_ivalue (a);
786 e2 = num_get_ivalue (b); 838 e2 = num_ivalue (b);
787 res = e1 % e2; 839 res = e1 % e2;
788 840
789 /* modulo should have same sign as second operand */ 841 /* modulo should have same sign as second operand */
790 if (res * e2 < 0) 842 if (res * e2 < 0)
791 res += e2; 843 res += e2;
792 844
793 num_set_ivalue (ret, res); 845 num_set_ivalue (ret, res);
794 return ret; 846 return ret;
795} 847}
796 848
849/* this completely disrespects NaNs, but r5rs doesn't even allow NaNs */
797static int 850static int
798num_eq (num a, num b) 851num_cmp (num a, num b)
799{ 852{
853 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
800 int ret; 854 int ret;
801 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
802 855
803 if (is_fixnum) 856 if (is_fixnum)
804 ret = num_get_ivalue (a) == num_get_ivalue (b); 857 {
858 IVALUE av = num_ivalue (a);
859 IVALUE bv = num_ivalue (b);
860
861 ret = av == bv ? 0 : av < bv ? -1 : +1;
862 }
805 else 863 else
806 ret = num_get_rvalue (a) == num_get_rvalue (b); 864 {
865 RVALUE av = num_rvalue (a);
866 RVALUE bv = num_rvalue (b);
867
868 ret = av == bv ? 0 : av < bv ? -1 : +1;
869 }
807 870
808 return ret; 871 return ret;
809} 872}
810
811
812static int
813num_gt (num a, num b)
814{
815 int ret;
816 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
817
818 if (is_fixnum)
819 ret = num_get_ivalue (a) > num_get_ivalue (b);
820 else
821 ret = num_get_rvalue (a) > num_get_rvalue (b);
822
823 return ret;
824}
825
826static int
827num_ge (num a, num b)
828{
829 return !num_lt (a, b);
830}
831
832static int
833num_lt (num a, num b)
834{
835 int ret;
836 int is_fixnum = num_is_fixnum (a) && num_is_fixnum (b);
837
838 if (is_fixnum)
839 ret = num_get_ivalue (a) < num_get_ivalue (b);
840 else
841 ret = num_get_rvalue (a) < num_get_rvalue (b);
842
843 return ret;
844}
845
846static int
847num_le (num a, num b)
848{
849 return !num_gt (a, b);
850}
851
852#if USE_MATH
853
854/* Round to nearest. Round to even if midway */
855static double
856round_per_R5RS (double x)
857{
858 double fl = floor (x);
859 double ce = ceil (x);
860 double dfl = x - fl;
861 double dce = ce - x;
862
863 if (dfl > dce)
864 return ce;
865 else if (dfl < dce)
866 return fl;
867 else
868 {
869 if (fmod (fl, 2.0) == 0.0) /* I imagine this holds */
870 return fl;
871 else
872 return ce;
873 }
874}
875#endif
876 873
877static int 874static int
878is_zero_rvalue (RVALUE x) 875is_zero_rvalue (RVALUE x)
879{ 876{
880#if USE_FLOAT 877 return x == 0;
878#if 0
879#if USE_REAL
881 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */ 880 return x < DBL_MIN && x > -DBL_MIN; /* why the hate of denormals? this should be == 0. */
882#else 881#else
883 return x == 0; 882 return x == 0;
884#endif 883#endif
885} 884#endif
886
887static long
888binary_decode (const char *s)
889{
890 long x = 0;
891
892 while (*s != 0 && (*s == '1' || *s == '0'))
893 {
894 x <<= 1;
895 x += *s - '0';
896 s++;
897 }
898
899 return x;
900} 885}
901 886
902/* allocate new cell segment */ 887/* allocate new cell segment */
903static int 888ecb_cold static int
904alloc_cellseg (SCHEME_P_ int n) 889alloc_cellseg (SCHEME_P)
905{ 890{
906 pointer newp; 891 struct cell *newp;
907 pointer last; 892 struct cell *last;
908 pointer p; 893 struct cell *p;
909 char *cp; 894 char *cp;
910 long i; 895 long i;
911 int k; 896 int k;
912 897
913 static int segsize = CELL_SEGSIZE >> 1; 898 static int segsize = CELL_SEGSIZE >> 1;
914 segsize <<= 1; 899 segsize <<= 1;
915 900
916 for (k = 0; k < n; k++)
917 {
918 if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
919 return k;
920
921 cp = malloc (segsize * sizeof (struct cell)); 901 cp = malloc (segsize * sizeof (struct cell));
922 902
923 if (!cp && USE_ERROR_CHECKING) 903 if (!cp && USE_ERROR_CHECKING)
924 return k; 904 return k;
925 905
926 i = ++SCHEME_V->last_cell_seg; 906 i = ++SCHEME_V->last_cell_seg;
927 SCHEME_V->alloc_seg[i] = cp; 907 SCHEME_V->alloc_seg[i] = cp;
928 908
929 /* insert new segment in address order */ 909 newp = (struct cell *)cp;
930 newp = (pointer)cp;
931 SCHEME_V->cell_seg[i] = newp; 910 SCHEME_V->cell_seg[i] = newp;
932 SCHEME_V->cell_segsize[i] = segsize; 911 SCHEME_V->cell_segsize[i] = segsize;
933
934 //TODO: insert, not swap
935 while (i > 0 && SCHEME_V->cell_seg[i - 1] > SCHEME_V->cell_seg[i])
936 {
937 p = SCHEME_V->cell_seg[i];
938 SCHEME_V->cell_seg[i] = SCHEME_V->cell_seg[i - 1];
939 SCHEME_V->cell_seg[i - 1] = p;
940
941 k = SCHEME_V->cell_segsize[i];
942 SCHEME_V->cell_segsize[i] = SCHEME_V->cell_segsize[i - 1];
943 SCHEME_V->cell_segsize[i - 1] = k;
944
945 --i;
946 }
947
948 SCHEME_V->fcells += segsize; 912 SCHEME_V->fcells += segsize;
949 last = newp + segsize - 1; 913 last = newp + segsize - 1;
950 914
951 for (p = newp; p <= last; p++) 915 for (p = newp; p <= last; p++)
952 { 916 {
917 pointer cp = POINTER (p);
953 set_typeflag (p, T_FREE); 918 set_typeflag (cp, T_PAIR);
954 set_car (p, NIL); 919 set_car (cp, NIL);
955 set_cdr (p, p + 1); 920 set_cdr (cp, POINTER (p + 1));
956 } 921 }
957 922
958 /* insert new cells in address order on free list */
959 if (SCHEME_V->free_cell == NIL || p < SCHEME_V->free_cell)
960 {
961 set_cdr (last, SCHEME_V->free_cell); 923 set_cdr (POINTER (last), SCHEME_V->free_cell);
962 SCHEME_V->free_cell = newp; 924 SCHEME_V->free_cell = POINTER (newp);
963 }
964 else
965 {
966 p = SCHEME_V->free_cell;
967 925
968 while (cdr (p) != NIL && newp > cdr (p))
969 p = cdr (p);
970
971 set_cdr (last, cdr (p));
972 set_cdr (p, newp);
973 }
974 }
975
976 return n; 926 return 1;
977} 927}
978 928
979/* get new cell. parameter a, b is marked by gc. */ 929/* get new cell. parameter a, b is marked by gc. */
980static INLINE pointer 930ecb_inline pointer
981get_cell_x (SCHEME_P_ pointer a, pointer b) 931get_cell_x (SCHEME_P_ pointer a, pointer b)
982{ 932{
983 if (SCHEME_V->free_cell == NIL) 933 if (ecb_expect_false (SCHEME_V->free_cell == NIL))
984 { 934 {
985 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 935 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
986 return S_SINK; 936 return S_SINK;
987 937
988 if (SCHEME_V->free_cell == NIL) 938 if (SCHEME_V->free_cell == NIL)
989 { 939 {
990 const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; 940 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1;
991 941
992 gc (SCHEME_A_ a, b); 942 gc (SCHEME_A_ a, b);
993 943
994 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 944 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
995 { 945 {
996 /* if only a few recovered, get more to avoid fruitless gc's */ 946 /* if only a few recovered, get more to avoid fruitless gc's */
997 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 947 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
998 { 948 {
999#if USE_ERROR_CHECKING 949#if USE_ERROR_CHECKING
1000 SCHEME_V->no_memory = 1; 950 SCHEME_V->no_memory = 1;
1001 return S_SINK; 951 return S_SINK;
1002#endif 952#endif
… …
1014 } 964 }
1015} 965}
1016 966
1017/* To retain recent allocs before interpreter knows about them - 967/* To retain recent allocs before interpreter knows about them -
1018 Tehom */ 968 Tehom */
1019 969ecb_hot static void
1020static void
1021push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 970push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1022{ 971{
1023 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 972 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1024 973
1025 set_typeflag (holder, T_PAIR); 974 set_typeflag (holder, T_PAIR);
… …
1027 set_car (holder, recent); 976 set_car (holder, recent);
1028 set_cdr (holder, car (S_SINK)); 977 set_cdr (holder, car (S_SINK));
1029 set_car (S_SINK, holder); 978 set_car (S_SINK, holder);
1030} 979}
1031 980
1032static pointer 981ecb_hot static pointer
1033get_cell (SCHEME_P_ pointer a, pointer b) 982get_cell (SCHEME_P_ pointer a, pointer b)
1034{ 983{
1035 pointer cell = get_cell_x (SCHEME_A_ a, b); 984 pointer cell = get_cell_x (SCHEME_A_ a, b);
1036 985
1037 /* For right now, include "a" and "b" in "cell" so that gc doesn't 986 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1046} 995}
1047 996
1048static pointer 997static pointer
1049get_vector_object (SCHEME_P_ uint32_t len, pointer init) 998get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1050{ 999{
1051 pointer v = get_cell_x (SCHEME_A_ 0, 0); 1000 pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1052 pointer *e = malloc (len * sizeof (pointer)); 1001 pointer *e = malloc (len * sizeof (pointer));
1053 1002
1054 if (!e && USE_ERROR_CHECKING) 1003 if (!e && USE_ERROR_CHECKING)
1055 return S_SINK; 1004 return S_SINK;
1056 1005
1057 /* Record it as a vector so that gc understands it. */ 1006 /* Record it as a vector so that gc understands it. */
1058 set_typeflag (v, T_VECTOR | T_ATOM); 1007 set_typeflag (v, T_VECTOR | T_ATOM);
1059 1008
1060 v->object.vector.vvalue = e; 1009 CELL(v)->object.vector.vvalue = e;
1061 v->object.vector.length = len; 1010 CELL(v)->object.vector.length = len;
1062 fill_vector (v, init); 1011 fill_vector (v, 0, init);
1063 push_recent_alloc (SCHEME_A_ v, NIL); 1012 push_recent_alloc (SCHEME_A_ v, NIL);
1064 1013
1065 return v; 1014 return v;
1066} 1015}
1067 1016
1068static INLINE void 1017ecb_inline void
1069ok_to_freely_gc (SCHEME_P) 1018ok_to_freely_gc (SCHEME_P)
1070{ 1019{
1071 set_car (S_SINK, NIL); 1020 set_car (S_SINK, NIL);
1072} 1021}
1073 1022
… …
1075static void 1024static void
1076check_cell_alloced (pointer p, int expect_alloced) 1025check_cell_alloced (pointer p, int expect_alloced)
1077{ 1026{
1078 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ 1027 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1079 if (typeflag (p) & !expect_alloced) 1028 if (typeflag (p) & !expect_alloced)
1080 xwrstr ("Cell is already allocated!\n"); 1029 putstr (SCHEME_A_ "Cell is already allocated!\n");
1081 1030
1082 if (!(typeflag (p)) & expect_alloced) 1031 if (!(typeflag (p)) & expect_alloced)
1083 xwrstr ("Cell is not allocated!\n"); 1032 putstr (SCHEME_A_ "Cell is not allocated!\n");
1084} 1033}
1085 1034
1086static void 1035static void
1087check_range_alloced (pointer p, int n, int expect_alloced) 1036check_range_alloced (pointer p, int n, int expect_alloced)
1088{ 1037{
… …
1094#endif 1043#endif
1095 1044
1096/* Medium level cell allocation */ 1045/* Medium level cell allocation */
1097 1046
1098/* get new cons cell */ 1047/* get new cons cell */
1099pointer 1048ecb_hot pointer
1100xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1049xcons (SCHEME_P_ pointer a, pointer b, int immutable)
1101{ 1050{
1102 pointer x = get_cell (SCHEME_A_ a, b); 1051 pointer x = get_cell (SCHEME_A_ a, b);
1103 1052
1104 set_typeflag (x, T_PAIR); 1053 set_typeflag (x, T_PAIR);
… …
1110 set_cdr (x, b); 1059 set_cdr (x, b);
1111 1060
1112 return x; 1061 return x;
1113} 1062}
1114 1063
1064ecb_cold static pointer
1065generate_symbol (SCHEME_P_ const char *name)
1066{
1067 pointer x = mk_string (SCHEME_A_ name);
1068 setimmutable (x);
1069 set_typeflag (x, T_SYMBOL | T_ATOM);
1070 return x;
1071}
1072
1115/* ========== oblist implementation ========== */ 1073/* ========== oblist implementation ========== */
1116 1074
1117#ifndef USE_OBJECT_LIST 1075#ifndef USE_OBJECT_LIST
1118 1076
1077static int
1119static int hash_fn (const char *key, int table_size); 1078hash_fn (const char *key, int table_size)
1079{
1080 const unsigned char *p = key;
1081 uint32_t hash = 2166136261;
1120 1082
1083 while (*p)
1084 hash = (hash ^ *p++) * 16777619;
1085
1086 return hash % table_size;
1087}
1088
1121static pointer 1089ecb_cold static pointer
1122oblist_initial_value (SCHEME_P) 1090oblist_initial_value (SCHEME_P)
1123{ 1091{
1124 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1092 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1125} 1093}
1126 1094
1127/* returns the new symbol */ 1095/* returns the new symbol */
1128static pointer 1096ecb_cold static pointer
1129oblist_add_by_name (SCHEME_P_ const char *name) 1097oblist_add_by_name (SCHEME_P_ const char *name)
1130{ 1098{
1131 int location; 1099 pointer x = generate_symbol (SCHEME_A_ name);
1132
1133 pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1134 set_typeflag (x, T_SYMBOL);
1135 setimmutable (car (x));
1136
1137 location = hash_fn (name, vector_length (SCHEME_V->oblist)); 1100 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1138 set_vector_elem (SCHEME_V->oblist, location, immutable_cons (x, vector_elem (SCHEME_V->oblist, location))); 1101 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1139 return x; 1102 return x;
1140} 1103}
1141 1104
1142static INLINE pointer 1105ecb_cold static pointer
1143oblist_find_by_name (SCHEME_P_ const char *name) 1106oblist_find_by_name (SCHEME_P_ const char *name)
1144{ 1107{
1145 int location; 1108 int location;
1146 pointer x; 1109 pointer x;
1147 char *s; 1110 char *s;
1148 1111
1149 location = hash_fn (name, vector_length (SCHEME_V->oblist)); 1112 location = hash_fn (name, veclength (SCHEME_V->oblist));
1150 1113
1151 for (x = vector_elem (SCHEME_V->oblist, location); x != NIL; x = cdr (x)) 1114 for (x = vector_get (SCHEME_V->oblist, location); x != NIL; x = cdr (x))
1152 { 1115 {
1153 s = symname (car (x)); 1116 s = symname (car (x));
1154 1117
1155 /* case-insensitive, per R5RS section 2 */ 1118 /* case-insensitive, per R5RS section 2 */
1156 if (stricmp (name, s) == 0) 1119 if (stricmp (name, s) == 0)
… …
1158 } 1121 }
1159 1122
1160 return NIL; 1123 return NIL;
1161} 1124}
1162 1125
1163static pointer 1126ecb_cold static pointer
1164oblist_all_symbols (SCHEME_P) 1127oblist_all_symbols (SCHEME_P)
1165{ 1128{
1166 int i; 1129 int i;
1167 pointer x; 1130 pointer x;
1168 pointer ob_list = NIL; 1131 pointer ob_list = NIL;
1169 1132
1170 for (i = 0; i < vector_length (SCHEME_V->oblist); i++) 1133 for (i = 0; i < veclength (SCHEME_V->oblist); i++)
1171 for (x = vector_elem (SCHEME_V->oblist, i); x != NIL; x = cdr (x)) 1134 for (x = vector_get (SCHEME_V->oblist, i); x != NIL; x = cdr (x))
1172 ob_list = cons (x, ob_list); 1135 ob_list = cons (x, ob_list);
1173 1136
1174 return ob_list; 1137 return ob_list;
1175} 1138}
1176 1139
1177#else 1140#else
1178 1141
1179static pointer 1142ecb_cold static pointer
1180oblist_initial_value (SCHEME_P) 1143oblist_initial_value (SCHEME_P)
1181{ 1144{
1182 return NIL; 1145 return NIL;
1183} 1146}
1184 1147
1185static INLINE pointer 1148ecb_cold static pointer
1186oblist_find_by_name (SCHEME_P_ const char *name) 1149oblist_find_by_name (SCHEME_P_ const char *name)
1187{ 1150{
1188 pointer x; 1151 pointer x;
1189 char *s; 1152 char *s;
1190 1153
… …
1199 1162
1200 return NIL; 1163 return NIL;
1201} 1164}
1202 1165
1203/* returns the new symbol */ 1166/* returns the new symbol */
1204static pointer 1167ecb_cold static pointer
1205oblist_add_by_name (SCHEME_P_ const char *name) 1168oblist_add_by_name (SCHEME_P_ const char *name)
1206{ 1169{
1207 pointer x; 1170 pointer x = generate_symbol (SCHEME_A_ name);
1208
1209 x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
1210 set_typeflag (x, T_SYMBOL);
1211 setimmutable (car (x));
1212 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1171 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1213 return x; 1172 return x;
1214} 1173}
1215 1174
1216static pointer 1175ecb_cold static pointer
1217oblist_all_symbols (SCHEME_P) 1176oblist_all_symbols (SCHEME_P)
1218{ 1177{
1219 return SCHEME_V->oblist; 1178 return SCHEME_V->oblist;
1220} 1179}
1221 1180
1222#endif 1181#endif
1223 1182
1224#if USE_PORTS 1183#if USE_PORTS
1225static pointer 1184ecb_cold static pointer
1226mk_port (SCHEME_P_ port *p) 1185mk_port (SCHEME_P_ port *p)
1227{ 1186{
1228 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1187 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1229 1188
1230 set_typeflag (x, T_PORT | T_ATOM); 1189 set_typeflag (x, T_PORT | T_ATOM);
1231 x->object.port = p; 1190 set_port (x, p);
1232 1191
1233 return x; 1192 return x;
1234} 1193}
1235#endif 1194#endif
1236 1195
1237pointer 1196ecb_cold pointer
1238mk_foreign_func (SCHEME_P_ foreign_func f) 1197mk_foreign_func (SCHEME_P_ foreign_func f)
1239{ 1198{
1240 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1199 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1241 1200
1242 set_typeflag (x, (T_FOREIGN | T_ATOM)); 1201 set_typeflag (x, T_FOREIGN | T_ATOM);
1243 x->object.ff = f; 1202 CELL(x)->object.ff = f;
1244 1203
1245 return x; 1204 return x;
1246} 1205}
1247 1206
1248INTERFACE pointer 1207INTERFACE pointer
1249mk_character (SCHEME_P_ int c) 1208mk_character (SCHEME_P_ int c)
1250{ 1209{
1251 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1210 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1252 1211
1253 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1212 set_typeflag (x, T_CHARACTER | T_ATOM);
1254 ivalue_unchecked (x) = c & 0xff; 1213 set_ivalue (x, c & 0xff);
1255 set_num_integer (x); 1214
1256 return x; 1215 return x;
1257} 1216}
1258 1217
1259/* get number atom (integer) */ 1218/* get number atom (integer) */
1260INTERFACE pointer 1219INTERFACE pointer
1261mk_integer (SCHEME_P_ long num) 1220mk_integer (SCHEME_P_ long n)
1262{ 1221{
1222 pointer p = 0;
1223 pointer *pp = &p;
1224
1225#if USE_INTCACHE
1226 if (n >= INTCACHE_MIN && n <= INTCACHE_MAX)
1227 pp = &SCHEME_V->intcache[n - INTCACHE_MIN];
1228#endif
1229
1230 if (!*pp)
1231 {
1263 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1232 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1264 1233
1265 set_typeflag (x, (T_NUMBER | T_ATOM)); 1234 set_typeflag (x, T_INTEGER | T_ATOM);
1266 ivalue_unchecked (x) = num; 1235 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
1267 set_num_integer (x); 1236 set_ivalue (x, n);
1237
1238 *pp = x;
1239 }
1240
1268 return x; 1241 return *pp;
1269} 1242}
1270 1243
1271INTERFACE pointer 1244INTERFACE pointer
1272mk_real (SCHEME_P_ RVALUE n) 1245mk_real (SCHEME_P_ RVALUE n)
1273{ 1246{
1247#if USE_REAL
1274 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1248 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1275 1249
1276 set_typeflag (x, (T_NUMBER | T_ATOM)); 1250 set_typeflag (x, T_REAL | T_ATOM);
1277 rvalue_unchecked (x) = n; 1251 set_rvalue (x, n);
1278 set_num_real (x); 1252
1279 return x; 1253 return x;
1254#else
1255 return mk_integer (SCHEME_A_ n);
1256#endif
1280} 1257}
1281 1258
1282static pointer 1259static pointer
1283mk_number (SCHEME_P_ const num n) 1260mk_number (SCHEME_P_ const num n)
1284{ 1261{
1262#if USE_REAL
1285 if (num_is_fixnum (n)) 1263 return num_is_fixnum (n)
1264 ? mk_integer (SCHEME_A_ num_ivalue (n))
1265 : mk_real (SCHEME_A_ num_rvalue (n));
1266#else
1286 return mk_integer (SCHEME_A_ num_get_ivalue (n)); 1267 return mk_integer (SCHEME_A_ num_ivalue (n));
1287 else 1268#endif
1288 return mk_real (SCHEME_A_ num_get_rvalue (n));
1289} 1269}
1290 1270
1291/* allocate name to string area */ 1271/* allocate name to string area */
1292static char * 1272static char *
1293store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill) 1273store_string (SCHEME_P_ uint32_t len_str, const char *str, char fill)
… …
1299 SCHEME_V->no_memory = 1; 1279 SCHEME_V->no_memory = 1;
1300 return SCHEME_V->strbuff; 1280 return SCHEME_V->strbuff;
1301 } 1281 }
1302 1282
1303 if (str) 1283 if (str)
1304 { 1284 memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
1305 int l = strlen (str);
1306
1307 if (l > len_str)
1308 l = len_str;
1309
1310 memcpy (q, str, l);
1311 q[l] = 0;
1312 }
1313 else 1285 else
1314 {
1315 memset (q, fill, len_str); 1286 memset (q, fill, len_str);
1287
1316 q[len_str] = 0; 1288 q[len_str] = 0;
1317 }
1318 1289
1319 return q; 1290 return q;
1320}
1321
1322/* get new string */
1323INTERFACE pointer
1324mk_string (SCHEME_P_ const char *str)
1325{
1326 return mk_counted_string (SCHEME_A_ str, strlen (str));
1327}
1328
1329INTERFACE pointer
1330mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1331{
1332 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1333
1334 set_typeflag (x, T_STRING | T_ATOM);
1335 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1336 strlength (x) = len;
1337 return x;
1338} 1291}
1339 1292
1340INTERFACE pointer 1293INTERFACE pointer
1341mk_empty_string (SCHEME_P_ uint32_t len, char fill) 1294mk_empty_string (SCHEME_P_ uint32_t len, char fill)
1342{ 1295{
… …
1347 strlength (x) = len; 1300 strlength (x) = len;
1348 return x; 1301 return x;
1349} 1302}
1350 1303
1351INTERFACE pointer 1304INTERFACE pointer
1305mk_counted_string (SCHEME_P_ const char *str, uint32_t len)
1306{
1307 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1308
1309 set_typeflag (x, T_STRING | T_ATOM);
1310 strvalue (x) = store_string (SCHEME_A_ len, str, 0);
1311 strlength (x) = len;
1312
1313 return x;
1314}
1315
1316INTERFACE pointer
1317mk_string (SCHEME_P_ const char *str)
1318{
1319 return mk_counted_string (SCHEME_A_ str, strlen (str));
1320}
1321
1322INTERFACE pointer
1352mk_vector (SCHEME_P_ uint32_t len) 1323mk_vector (SCHEME_P_ uint32_t len)
1353{ 1324{
1354 return get_vector_object (SCHEME_A_ len, NIL); 1325 return get_vector_object (SCHEME_A_ len, NIL);
1355} 1326}
1356 1327
1357INTERFACE void 1328INTERFACE void
1358fill_vector (pointer vec, pointer obj) 1329fill_vector (pointer vec, uint32_t start, pointer obj)
1359{ 1330{
1360 int i; 1331 int i;
1361 1332
1362 for (i = 0; i < vec->object.vector.length; i++) 1333 for (i = start; i < veclength (vec); i++)
1363 vec->object.vector.vvalue[i] = obj; 1334 vecvalue (vec)[i] = obj;
1335}
1336
1337INTERFACE void
1338vector_resize (pointer vec, uint32_t newsize, pointer fill)
1339{
1340 uint32_t oldsize = veclength (vec);
1341 vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer));
1342 veclength (vec) = newsize;
1343 fill_vector (vec, oldsize, fill);
1364} 1344}
1365 1345
1366INTERFACE pointer 1346INTERFACE pointer
1367vector_elem (pointer vec, uint32_t ielem) 1347vector_get (pointer vec, uint32_t ielem)
1368{ 1348{
1369 return vec->object.vector.vvalue[ielem]; 1349 return vecvalue(vec)[ielem];
1370} 1350}
1371 1351
1372INTERFACE void 1352INTERFACE void
1373set_vector_elem (pointer vec, uint32_t ielem, pointer a) 1353vector_set (pointer vec, uint32_t ielem, pointer a)
1374{ 1354{
1375 vec->object.vector.vvalue[ielem] = a; 1355 vecvalue(vec)[ielem] = a;
1376} 1356}
1377 1357
1378/* get new symbol */ 1358/* get new symbol */
1379INTERFACE pointer 1359INTERFACE pointer
1380mk_symbol (SCHEME_P_ const char *name) 1360mk_symbol (SCHEME_P_ const char *name)
… …
1386 x = oblist_add_by_name (SCHEME_A_ name); 1366 x = oblist_add_by_name (SCHEME_A_ name);
1387 1367
1388 return x; 1368 return x;
1389} 1369}
1390 1370
1391INTERFACE pointer 1371ecb_cold INTERFACE pointer
1392gensym (SCHEME_P) 1372gensym (SCHEME_P)
1393{ 1373{
1394 pointer x; 1374 pointer x;
1395 char name[40]; 1375 char name[40] = "gensym-";
1396
1397 for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
1398 {
1399 strcpy (name, "gensym-");
1400 xnum (name + 7, SCHEME_V->gensym_cnt); 1376 xnum (name + 7, ++SCHEME_V->gensym_cnt);
1401 1377
1402 /* first check oblist */ 1378 return generate_symbol (SCHEME_A_ name);
1403 x = oblist_find_by_name (SCHEME_A_ name); 1379}
1404 1380
1405 if (x != NIL) 1381static int
1406 continue; 1382is_gensym (SCHEME_P_ pointer x)
1407 else 1383{
1408 { 1384 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1409 x = oblist_add_by_name (SCHEME_A_ name);
1410 return x;
1411 }
1412 }
1413
1414 return NIL;
1415} 1385}
1416 1386
1417/* make symbol or number atom from string */ 1387/* make symbol or number atom from string */
1418static pointer 1388ecb_cold static pointer
1419mk_atom (SCHEME_P_ char *q) 1389mk_atom (SCHEME_P_ char *q)
1420{ 1390{
1421 char c, *p; 1391 char c, *p;
1422 int has_dec_point = 0; 1392 int has_dec_point = 0;
1423 int has_fp_exp = 0; 1393 int has_fp_exp = 0;
1424 1394
1425#if USE_COLON_HOOK 1395#if USE_COLON_HOOK
1426
1427 if ((p = strstr (q, "::")) != 0) 1396 if ((p = strstr (q, "::")) != 0)
1428 { 1397 {
1429 *p = 0; 1398 *p = 0;
1430 return cons (SCHEME_V->COLON_HOOK, 1399 return cons (SCHEME_V->COLON_HOOK,
1431 cons (cons (SCHEME_V->QUOTE, 1400 cons (cons (SCHEME_V->QUOTE,
1432 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL))); 1401 cons (mk_atom (SCHEME_A_ p + 2), NIL)), cons (mk_symbol (SCHEME_A_ strlwr (q)), NIL)));
1433 } 1402 }
1434
1435#endif 1403#endif
1436 1404
1437 p = q; 1405 p = q;
1438 c = *p++; 1406 c = *p++;
1439 1407
… …
1475 } 1443 }
1476 else if ((c == 'e') || (c == 'E')) 1444 else if ((c == 'e') || (c == 'E'))
1477 { 1445 {
1478 if (!has_fp_exp) 1446 if (!has_fp_exp)
1479 { 1447 {
1480 has_dec_point = 1; /* decimal point illegal 1448 has_dec_point = 1; /* decimal point illegal from now on */
1481 from now on */
1482 p++; 1449 p++;
1483 1450
1484 if ((*p == '-') || (*p == '+') || isdigit (*p)) 1451 if ((*p == '-') || (*p == '+') || isdigit (*p))
1485 continue; 1452 continue;
1486 } 1453 }
… …
1488 1455
1489 return mk_symbol (SCHEME_A_ strlwr (q)); 1456 return mk_symbol (SCHEME_A_ strlwr (q));
1490 } 1457 }
1491 } 1458 }
1492 1459
1493#if USE_FLOAT 1460#if USE_REAL
1494 if (has_dec_point) 1461 if (has_dec_point)
1495 return mk_real (SCHEME_A_ atof (q)); 1462 return mk_real (SCHEME_A_ atof (q));
1496#endif 1463#endif
1497 1464
1498 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1465 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1499} 1466}
1500 1467
1501/* make constant */ 1468/* make constant */
1502static pointer 1469ecb_cold static pointer
1503mk_sharp_const (SCHEME_P_ char *name) 1470mk_sharp_const (SCHEME_P_ char *name)
1504{ 1471{
1505 long x;
1506 char tmp[STRBUFFSIZE];
1507
1508 if (!strcmp (name, "t")) 1472 if (!strcmp (name, "t"))
1509 return S_T; 1473 return S_T;
1510 else if (!strcmp (name, "f")) 1474 else if (!strcmp (name, "f"))
1511 return S_F; 1475 return S_F;
1512 else if (*name == 'o') /* #o (octal) */
1513 {
1514 x = strtol (name + 1, 0, 8);
1515 return mk_integer (SCHEME_A_ x);
1516 }
1517 else if (*name == 'd') /* #d (decimal) */
1518 {
1519 x = strtol (name + 1, 0, 10);
1520 return mk_integer (SCHEME_A_ x);
1521 }
1522 else if (*name == 'x') /* #x (hex) */
1523 {
1524 x = strtol (name + 1, 0, 16);
1525 return mk_integer (SCHEME_A_ x);
1526 }
1527 else if (*name == 'b') /* #b (binary) */
1528 {
1529 x = binary_decode (name + 1);
1530 return mk_integer (SCHEME_A_ x);
1531 }
1532 else if (*name == '\\') /* #\w (character) */ 1476 else if (*name == '\\') /* #\w (character) */
1533 { 1477 {
1534 int c = 0; 1478 int c;
1535 1479
1480 // TODO: optimise
1536 if (stricmp (name + 1, "space") == 0) 1481 if (stricmp (name + 1, "space") == 0)
1537 c = ' '; 1482 c = ' ';
1538 else if (stricmp (name + 1, "newline") == 0) 1483 else if (stricmp (name + 1, "newline") == 0)
1539 c = '\n'; 1484 c = '\n';
1540 else if (stricmp (name + 1, "return") == 0) 1485 else if (stricmp (name + 1, "return") == 0)
1541 c = '\r'; 1486 c = '\r';
1542 else if (stricmp (name + 1, "tab") == 0) 1487 else if (stricmp (name + 1, "tab") == 0)
1543 c = '\t'; 1488 c = '\t';
1489 else if (stricmp (name + 1, "alarm") == 0)
1490 c = 0x07;
1491 else if (stricmp (name + 1, "backspace") == 0)
1492 c = 0x08;
1493 else if (stricmp (name + 1, "escape") == 0)
1494 c = 0x1b;
1495 else if (stricmp (name + 1, "delete") == 0)
1496 c = 0x7f;
1497 else if (stricmp (name + 1, "null") == 0)
1498 c = 0;
1544 else if (name[1] == 'x' && name[2] != 0) 1499 else if (name[1] == 'x' && name[2] != 0)
1545 { 1500 {
1546 int c1 = strtol (name + 2, 0, 16); 1501 long c1 = strtol (name + 2, 0, 16);
1547 1502
1548 if (c1 <= UCHAR_MAX) 1503 if (0 <= c1 && c1 <= UCHAR_MAX)
1549 c = c1; 1504 c = c1;
1550 else 1505 else
1551 return NIL; 1506 return NIL;
1552 1507 }
1553#if USE_ASCII_NAMES 1508#if USE_ASCII_NAMES
1554 }
1555 else if (is_ascii_name (name + 1, &c)) 1509 else if (is_ascii_name (name + 1, &c))
1556 {
1557 /* nothing */ 1510 /* nothing */;
1558#endif 1511#endif
1559 }
1560 else if (name[2] == 0) 1512 else if (name[2] == 0)
1561 c = name[1]; 1513 c = name[1];
1562 else 1514 else
1563 return NIL; 1515 return NIL;
1564 1516
1565 return mk_character (SCHEME_A_ c); 1517 return mk_character (SCHEME_A_ c);
1566 } 1518 }
1567 else 1519 else
1520 {
1521 /* identify base by string index */
1522 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x";
1523 char *base = strchr (baseidx, *name);
1524
1525 if (base)
1526 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1527
1568 return NIL; 1528 return NIL;
1529 }
1569} 1530}
1570 1531
1571/* ========== garbage collector ========== */ 1532/* ========== garbage collector ========== */
1533
1534static void
1535finalize_cell (SCHEME_P_ pointer a)
1536{
1537 /* TODO, fast bitmap check? */
1538 if (is_string (a) || is_symbol (a))
1539 free (strvalue (a));
1540 else if (is_vector (a))
1541 free (vecvalue (a));
1542#if USE_PORTS
1543 else if (is_port (a))
1544 {
1545 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1546 port_close (SCHEME_A_ a, port_input | port_output);
1547
1548 free (port (a));
1549 }
1550#endif
1551}
1572 1552
1573/*-- 1553/*--
1574 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1554 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1575 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1555 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1576 * for marking. 1556 * for marking.
1557 *
1558 * The exception is vectors - vectors are currently marked recursively,
1559 * which is inherited form tinyscheme and could be fixed by having another
1560 * word of context in the vector
1577 */ 1561 */
1578static void 1562ecb_hot static void
1579mark (pointer a) 1563mark (pointer a)
1580{ 1564{
1581 pointer t, q, p; 1565 pointer t, q, p;
1582 1566
1583 t = 0; 1567 t = 0;
1584 p = a; 1568 p = a;
1585E2: 1569E2:
1586 setmark (p); 1570 setmark (p);
1587 1571
1588 if (is_vector (p)) 1572 if (ecb_expect_false (is_vector (p)))
1589 { 1573 {
1590 int i; 1574 int i;
1591 1575
1592 for (i = 0; i < p->object.vector.length; i++) 1576 for (i = 0; i < veclength (p); i++)
1593 mark (p->object.vector.vvalue[i]); 1577 mark (vecvalue (p)[i]);
1594 } 1578 }
1595 1579
1596 if (is_atom (p)) 1580 if (is_atom (p))
1597 goto E6; 1581 goto E6;
1598 1582
… …
1640 p = q; 1624 p = q;
1641 goto E6; 1625 goto E6;
1642 } 1626 }
1643} 1627}
1644 1628
1629ecb_hot static void
1630gc_free (SCHEME_P)
1631{
1632 int i;
1633 uint32_t total = 0;
1634
1635 /* Here we scan the cells to build the free-list. */
1636 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1637 {
1638 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1639 struct cell *p;
1640 total += SCHEME_V->cell_segsize [i];
1641
1642 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1643 {
1644 pointer c = POINTER (p);
1645
1646 if (is_mark (c))
1647 clrmark (c);
1648 else
1649 {
1650 /* reclaim cell */
1651 if (typeflag (c) != T_PAIR)
1652 {
1653 finalize_cell (SCHEME_A_ c);
1654 set_typeflag (c, T_PAIR);
1655 set_car (c, NIL);
1656 }
1657
1658 ++SCHEME_V->fcells;
1659 set_cdr (c, SCHEME_V->free_cell);
1660 SCHEME_V->free_cell = c;
1661 }
1662 }
1663 }
1664
1665 if (SCHEME_V->gc_verbose)
1666 {
1667 putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n");
1668 }
1669}
1670
1645/* garbage collection. parameter a, b is marked. */ 1671/* garbage collection. parameter a, b is marked. */
1646static void 1672ecb_cold static void
1647gc (SCHEME_P_ pointer a, pointer b) 1673gc (SCHEME_P_ pointer a, pointer b)
1648{ 1674{
1649 pointer p;
1650 int i; 1675 int i;
1651 1676
1652 if (SCHEME_V->gc_verbose) 1677 if (SCHEME_V->gc_verbose)
1653 putstr (SCHEME_A_ "gc..."); 1678 putstr (SCHEME_A_ "gc...");
1654 1679
… …
1670 /* Mark recent objects the interpreter doesn't know about yet. */ 1695 /* Mark recent objects the interpreter doesn't know about yet. */
1671 mark (car (S_SINK)); 1696 mark (car (S_SINK));
1672 /* Mark any older stuff above nested C calls */ 1697 /* Mark any older stuff above nested C calls */
1673 mark (SCHEME_V->c_nest); 1698 mark (SCHEME_V->c_nest);
1674 1699
1700#if USE_INTCACHE
1701 /* mark intcache */
1702 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1703 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1704 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1705#endif
1706
1675 /* mark variables a, b */ 1707 /* mark variables a, b */
1676 mark (a); 1708 mark (a);
1677 mark (b); 1709 mark (b);
1678 1710
1679 /* garbage collect */ 1711 /* garbage collect */
1680 clrmark (NIL); 1712 clrmark (NIL);
1681 SCHEME_V->fcells = 0; 1713 SCHEME_V->fcells = 0;
1682 SCHEME_V->free_cell = NIL; 1714 SCHEME_V->free_cell = NIL;
1683 1715
1684 /* free-list is kept sorted by address so as to maintain consecutive
1685 ranges, if possible, for use with vectors. Here we scan the cells
1686 (which are also kept sorted by address) downwards to build the
1687 free-list in sorted order.
1688 */
1689 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1690 {
1691 p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1692
1693 while (--p >= SCHEME_V->cell_seg[i])
1694 {
1695 if (is_mark (p))
1696 clrmark (p);
1697 else
1698 {
1699 /* reclaim cell */
1700 if (typeflag (p) != T_FREE)
1701 {
1702 finalize_cell (SCHEME_A_ p);
1703 set_typeflag (p, T_FREE);
1704 set_car (p, NIL);
1705 }
1706
1707 ++SCHEME_V->fcells;
1708 set_cdr (p, SCHEME_V->free_cell);
1709 SCHEME_V->free_cell = p;
1710 }
1711 }
1712 }
1713
1714 if (SCHEME_V->gc_verbose) 1716 if (SCHEME_V->gc_verbose)
1715 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n"); 1717 putstr (SCHEME_A_ "freeing...");
1716}
1717 1718
1718static void 1719 gc_free (SCHEME_A);
1719finalize_cell (SCHEME_P_ pointer a)
1720{
1721 if (is_string (a))
1722 free (strvalue (a));
1723 else if (is_vector (a))
1724 free (a->object.vector.vvalue);
1725#if USE_PORTS
1726 else if (is_port (a))
1727 {
1728 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1729 port_close (SCHEME_A_ a, port_input | port_output);
1730
1731 free (a->object.port);
1732 }
1733#endif
1734} 1720}
1735 1721
1736/* ========== Routines for Reading ========== */ 1722/* ========== Routines for Reading ========== */
1737 1723
1738static int 1724ecb_cold static int
1739file_push (SCHEME_P_ const char *fname) 1725file_push (SCHEME_P_ const char *fname)
1740{ 1726{
1741#if USE_PORTS 1727#if USE_PORTS
1742 int fin; 1728 int fin;
1743 1729
… …
1752 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1738 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1753 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1739 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1754 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; 1740 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1755 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; 1741 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1756 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1742 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1757 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1743 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1758 1744
1759#if SHOW_ERROR_LINE 1745#if SHOW_ERROR_LINE
1760 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1746 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1761 1747
1762 if (fname) 1748 if (fname)
… …
1769#else 1755#else
1770 return 1; 1756 return 1;
1771#endif 1757#endif
1772} 1758}
1773 1759
1774static void 1760ecb_cold static void
1775file_pop (SCHEME_P) 1761file_pop (SCHEME_P)
1776{ 1762{
1777 if (SCHEME_V->file_i != 0) 1763 if (SCHEME_V->file_i != 0)
1778 { 1764 {
1779 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1765 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1780#if USE_PORTS 1766#if USE_PORTS
1781 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1767 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1782#endif 1768#endif
1783 SCHEME_V->file_i--; 1769 SCHEME_V->file_i--;
1784 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1770 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1785 } 1771 }
1786} 1772}
1787 1773
1788static int 1774ecb_cold static int
1789file_interactive (SCHEME_P) 1775file_interactive (SCHEME_P)
1790{ 1776{
1791#if USE_PORTS 1777#if USE_PORTS
1792 return SCHEME_V->file_i == 0 1778 return SCHEME_V->file_i == 0
1793 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1779 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1794 && (SCHEME_V->inport->object.port->kind & port_file); 1780 && (port (SCHEME_V->inport)->kind & port_file);
1795#else 1781#else
1796 return 0; 1782 return 0;
1797#endif 1783#endif
1798} 1784}
1799 1785
1800#if USE_PORTS 1786#if USE_PORTS
1801static port * 1787ecb_cold static port *
1802port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1788port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1803{ 1789{
1804 int fd; 1790 int fd;
1805 int flags; 1791 int flags;
1806 char *rw; 1792 char *rw;
… …
1829# endif 1815# endif
1830 1816
1831 return pt; 1817 return pt;
1832} 1818}
1833 1819
1834static pointer 1820ecb_cold static pointer
1835port_from_filename (SCHEME_P_ const char *fn, int prop) 1821port_from_filename (SCHEME_P_ const char *fn, int prop)
1836{ 1822{
1837 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1823 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1838 1824
1839 if (!pt && USE_ERROR_CHECKING) 1825 if (!pt && USE_ERROR_CHECKING)
1840 return NIL; 1826 return NIL;
1841 1827
1842 return mk_port (SCHEME_A_ pt); 1828 return mk_port (SCHEME_A_ pt);
1843} 1829}
1844 1830
1845static port * 1831ecb_cold static port *
1846port_rep_from_file (SCHEME_P_ int f, int prop) 1832port_rep_from_file (SCHEME_P_ int f, int prop)
1847{ 1833{
1848 port *pt = malloc (sizeof *pt); 1834 port *pt = malloc (sizeof *pt);
1849 1835
1850 if (!pt && USE_ERROR_CHECKING) 1836 if (!pt && USE_ERROR_CHECKING)
… …
1855 pt->rep.stdio.file = f; 1841 pt->rep.stdio.file = f;
1856 pt->rep.stdio.closeit = 0; 1842 pt->rep.stdio.closeit = 0;
1857 return pt; 1843 return pt;
1858} 1844}
1859 1845
1860static pointer 1846ecb_cold static pointer
1861port_from_file (SCHEME_P_ int f, int prop) 1847port_from_file (SCHEME_P_ int f, int prop)
1862{ 1848{
1863 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1849 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1864 1850
1865 if (!pt && USE_ERROR_CHECKING) 1851 if (!pt && USE_ERROR_CHECKING)
1866 return NIL; 1852 return NIL;
1867 1853
1868 return mk_port (SCHEME_A_ pt); 1854 return mk_port (SCHEME_A_ pt);
1869} 1855}
1870 1856
1871static port * 1857ecb_cold static port *
1872port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1858port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1873{ 1859{
1874 port *pt = malloc (sizeof (port)); 1860 port *pt = malloc (sizeof (port));
1875 1861
1876 if (!pt && USE_ERROR_CHECKING) 1862 if (!pt && USE_ERROR_CHECKING)
… …
1882 pt->rep.string.curr = start; 1868 pt->rep.string.curr = start;
1883 pt->rep.string.past_the_end = past_the_end; 1869 pt->rep.string.past_the_end = past_the_end;
1884 return pt; 1870 return pt;
1885} 1871}
1886 1872
1887static pointer 1873ecb_cold static pointer
1888port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1874port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1889{ 1875{
1890 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1876 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1891 1877
1892 if (!pt && USE_ERROR_CHECKING) 1878 if (!pt && USE_ERROR_CHECKING)
… …
1895 return mk_port (SCHEME_A_ pt); 1881 return mk_port (SCHEME_A_ pt);
1896} 1882}
1897 1883
1898# define BLOCK_SIZE 256 1884# define BLOCK_SIZE 256
1899 1885
1900static port * 1886ecb_cold static port *
1901port_rep_from_scratch (SCHEME_P) 1887port_rep_from_scratch (SCHEME_P)
1902{ 1888{
1903 char *start; 1889 char *start;
1904 port *pt = malloc (sizeof (port)); 1890 port *pt = malloc (sizeof (port));
1905 1891
… …
1919 pt->rep.string.curr = start; 1905 pt->rep.string.curr = start;
1920 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1906 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1921 return pt; 1907 return pt;
1922} 1908}
1923 1909
1924static pointer 1910ecb_cold static pointer
1925port_from_scratch (SCHEME_P) 1911port_from_scratch (SCHEME_P)
1926{ 1912{
1927 port *pt = port_rep_from_scratch (SCHEME_A); 1913 port *pt = port_rep_from_scratch (SCHEME_A);
1928 1914
1929 if (!pt && USE_ERROR_CHECKING) 1915 if (!pt && USE_ERROR_CHECKING)
1930 return NIL; 1916 return NIL;
1931 1917
1932 return mk_port (SCHEME_A_ pt); 1918 return mk_port (SCHEME_A_ pt);
1933} 1919}
1934 1920
1935static void 1921ecb_cold static void
1936port_close (SCHEME_P_ pointer p, int flag) 1922port_close (SCHEME_P_ pointer p, int flag)
1937{ 1923{
1938 port *pt = p->object.port; 1924 port *pt = port (p);
1939 1925
1940 pt->kind &= ~flag; 1926 pt->kind &= ~flag;
1941 1927
1942 if ((pt->kind & (port_input | port_output)) == 0) 1928 if ((pt->kind & (port_input | port_output)) == 0)
1943 { 1929 {
… …
1964/* get new character from input file */ 1950/* get new character from input file */
1965static int 1951static int
1966inchar (SCHEME_P) 1952inchar (SCHEME_P)
1967{ 1953{
1968 int c; 1954 int c;
1969 port *pt; 1955 port *pt = port (SCHEME_V->inport);
1970
1971 pt = SCHEME_V->inport->object.port;
1972 1956
1973 if (pt->kind & port_saw_EOF) 1957 if (pt->kind & port_saw_EOF)
1974 return EOF; 1958 return EOF;
1975 1959
1976 c = basic_inchar (pt); 1960 c = basic_inchar (pt);
… …
2043 port *pt; 2027 port *pt;
2044 2028
2045 if (c == EOF) 2029 if (c == EOF)
2046 return; 2030 return;
2047 2031
2048 pt = SCHEME_V->inport->object.port; 2032 pt = port (SCHEME_V->inport);
2049 pt->unget = c; 2033 pt->unget = c;
2050#else 2034#else
2051 if (c == EOF) 2035 if (c == EOF)
2052 return; 2036 return;
2053 2037
2054 ungot = c; 2038 ungot = c;
2055#endif 2039#endif
2056} 2040}
2057 2041
2058#if USE_PORTS 2042#if USE_PORTS
2059static int 2043ecb_cold static int
2060realloc_port_string (SCHEME_P_ port *p) 2044realloc_port_string (SCHEME_P_ port *p)
2061{ 2045{
2062 char *start = p->rep.string.start; 2046 char *start = p->rep.string.start;
2063 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2047 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2064 char *str = malloc (new_size); 2048 char *str = malloc (new_size);
… …
2077 else 2061 else
2078 return 0; 2062 return 0;
2079} 2063}
2080#endif 2064#endif
2081 2065
2082INTERFACE void 2066ecb_cold INTERFACE void
2083putstr (SCHEME_P_ const char *s) 2067putstr (SCHEME_P_ const char *s)
2084{ 2068{
2085#if USE_PORTS 2069#if USE_PORTS
2086 port *pt = SCHEME_V->outport->object.port; 2070 port *pt = port (SCHEME_V->outport);
2087 2071
2088 if (pt->kind & port_file) 2072 if (pt->kind & port_file)
2089 write (pt->rep.stdio.file, s, strlen (s)); 2073 write (pt->rep.stdio.file, s, strlen (s));
2090 else 2074 else
2091 for (; *s; s++) 2075 for (; *s; s++)
… …
2093 *pt->rep.string.curr++ = *s; 2077 *pt->rep.string.curr++ = *s;
2094 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) 2078 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2095 *pt->rep.string.curr++ = *s; 2079 *pt->rep.string.curr++ = *s;
2096 2080
2097#else 2081#else
2098 xwrstr (s); 2082 write (pt->rep.stdio.file, s, strlen (s));
2099#endif 2083#endif
2100} 2084}
2101 2085
2102static void 2086ecb_cold static void
2103putchars (SCHEME_P_ const char *s, int len) 2087putchars (SCHEME_P_ const char *s, int len)
2104{ 2088{
2105#if USE_PORTS 2089#if USE_PORTS
2106 port *pt = SCHEME_V->outport->object.port; 2090 port *pt = port (SCHEME_V->outport);
2107 2091
2108 if (pt->kind & port_file) 2092 if (pt->kind & port_file)
2109 write (pt->rep.stdio.file, s, len); 2093 write (pt->rep.stdio.file, s, len);
2110 else 2094 else
2111 { 2095 {
… …
2121#else 2105#else
2122 write (1, s, len); 2106 write (1, s, len);
2123#endif 2107#endif
2124} 2108}
2125 2109
2126INTERFACE void 2110ecb_cold INTERFACE void
2127putcharacter (SCHEME_P_ int c) 2111putcharacter (SCHEME_P_ int c)
2128{ 2112{
2129#if USE_PORTS 2113#if USE_PORTS
2130 port *pt = SCHEME_V->outport->object.port; 2114 port *pt = port (SCHEME_V->outport);
2131 2115
2132 if (pt->kind & port_file) 2116 if (pt->kind & port_file)
2133 { 2117 {
2134 char cc = c; 2118 char cc = c;
2135 write (pt->rep.stdio.file, &cc, 1); 2119 write (pt->rep.stdio.file, &cc, 1);
… …
2147 write (1, &c, 1); 2131 write (1, &c, 1);
2148#endif 2132#endif
2149} 2133}
2150 2134
2151/* read characters up to delimiter, but cater to character constants */ 2135/* read characters up to delimiter, but cater to character constants */
2152static char * 2136ecb_cold static char *
2153readstr_upto (SCHEME_P_ char *delim) 2137readstr_upto (SCHEME_P_ int skip, const char *delim)
2154{ 2138{
2155 char *p = SCHEME_V->strbuff; 2139 char *p = SCHEME_V->strbuff + skip;
2156 2140
2157 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2141 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
2158 2142
2159 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\') 2143 if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
2160 *p = 0; 2144 *p = 0;
… …
2166 2150
2167 return SCHEME_V->strbuff; 2151 return SCHEME_V->strbuff;
2168} 2152}
2169 2153
2170/* read string expression "xxx...xxx" */ 2154/* read string expression "xxx...xxx" */
2171static pointer 2155ecb_cold static pointer
2172readstrexp (SCHEME_P) 2156readstrexp (SCHEME_P_ char delim)
2173{ 2157{
2174 char *p = SCHEME_V->strbuff; 2158 char *p = SCHEME_V->strbuff;
2175 int c; 2159 int c;
2176 int c1 = 0; 2160 int c1 = 0;
2177 enum
2178 { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok; 2161 enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
2179 2162
2180 for (;;) 2163 for (;;)
2181 { 2164 {
2182 c = inchar (SCHEME_A); 2165 c = inchar (SCHEME_A);
2183 2166
… …
2185 return S_F; 2168 return S_F;
2186 2169
2187 switch (state) 2170 switch (state)
2188 { 2171 {
2189 case st_ok: 2172 case st_ok:
2190 switch (c) 2173 if (ecb_expect_false (c == delim))
2191 {
2192 case '\\':
2193 state = st_bsl;
2194 break;
2195
2196 case '"':
2197 *p = 0;
2198 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff); 2174 return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
2199 2175
2200 default: 2176 if (ecb_expect_false (c == '\\'))
2177 state = st_bsl;
2178 else
2201 *p++ = c; 2179 *p++ = c;
2202 break;
2203 }
2204 2180
2205 break; 2181 break;
2206 2182
2207 case st_bsl: 2183 case st_bsl:
2208 switch (c) 2184 switch (c)
… …
2217 case '7': 2193 case '7':
2218 state = st_oct1; 2194 state = st_oct1;
2219 c1 = c - '0'; 2195 c1 = c - '0';
2220 break; 2196 break;
2221 2197
2198 case 'a': *p++ = '\a'; state = st_ok; break;
2199 case 'n': *p++ = '\n'; state = st_ok; break;
2200 case 'r': *p++ = '\r'; state = st_ok; break;
2201 case 't': *p++ = '\t'; state = st_ok; break;
2202
2203 //TODO: \whitespace eol whitespace
2204
2205 //TODO: x should end in ;, not two-digit hex
2222 case 'x': 2206 case 'x':
2223 case 'X': 2207 case 'X':
2224 state = st_x1; 2208 state = st_x1;
2225 c1 = 0; 2209 c1 = 0;
2226 break; 2210 break;
2227 2211
2228 case 'n':
2229 *p++ = '\n';
2230 state = st_ok;
2231 break;
2232
2233 case 't':
2234 *p++ = '\t';
2235 state = st_ok;
2236 break;
2237
2238 case 'r':
2239 *p++ = '\r';
2240 state = st_ok;
2241 break;
2242
2243 case '"':
2244 *p++ = '"';
2245 state = st_ok;
2246 break;
2247
2248 default: 2212 default:
2249 *p++ = c; 2213 *p++ = c;
2250 state = st_ok; 2214 state = st_ok;
2251 break; 2215 break;
2252 } 2216 }
2253 2217
2254 break; 2218 break;
2255 2219
2256 case st_x1: 2220 case st_x1:
2257 case st_x2: 2221 case st_x2:
2258 c = toupper (c); 2222 c = tolower (c);
2259 2223
2260 if (c >= '0' && c <= 'F') 2224 if (c >= '0' && c <= '9')
2261 {
2262 if (c <= '9')
2263 c1 = (c1 << 4) + c - '0'; 2225 c1 = (c1 << 4) + c - '0';
2264 else 2226 else if (c >= 'a' && c <= 'f')
2265 c1 = (c1 << 4) + c - 'A' + 10; 2227 c1 = (c1 << 4) + c - 'a' + 10;
2266
2267 if (state == st_x1)
2268 state = st_x2;
2269 else
2270 {
2271 *p++ = c1;
2272 state = st_ok;
2273 }
2274 }
2275 else 2228 else
2276 return S_F; 2229 return S_F;
2230
2231 if (state == st_x1)
2232 state = st_x2;
2233 else
2234 {
2235 *p++ = c1;
2236 state = st_ok;
2237 }
2277 2238
2278 break; 2239 break;
2279 2240
2280 case st_oct1: 2241 case st_oct1:
2281 case st_oct2: 2242 case st_oct2:
… …
2285 backchar (SCHEME_A_ c); 2246 backchar (SCHEME_A_ c);
2286 state = st_ok; 2247 state = st_ok;
2287 } 2248 }
2288 else 2249 else
2289 { 2250 {
2290 if (state == st_oct2 && c1 >= 32) 2251 if (state == st_oct2 && c1 >= ' ')
2291 return S_F; 2252 return S_F;
2292 2253
2293 c1 = (c1 << 3) + (c - '0'); 2254 c1 = (c1 << 3) + (c - '0');
2294 2255
2295 if (state == st_oct1) 2256 if (state == st_oct1)
… …
2300 state = st_ok; 2261 state = st_ok;
2301 } 2262 }
2302 } 2263 }
2303 2264
2304 break; 2265 break;
2305
2306 } 2266 }
2307 } 2267 }
2308} 2268}
2309 2269
2310/* check c is in chars */ 2270/* check c is in chars */
2311static INLINE int 2271ecb_cold int
2312is_one_of (char *s, int c) 2272is_one_of (const char *s, int c)
2313{ 2273{
2314 if (c == EOF)
2315 return 1;
2316
2317 return !!strchr (s, c); 2274 return c == EOF || !!strchr (s, c);
2318} 2275}
2319 2276
2320/* skip white characters */ 2277/* skip white characters */
2321static INLINE int 2278ecb_cold int
2322skipspace (SCHEME_P) 2279skipspace (SCHEME_P)
2323{ 2280{
2324 int c, curr_line = 0; 2281 int c, curr_line = 0;
2325 2282
2326 do 2283 do
2327 { 2284 {
2328 c = inchar (SCHEME_A); 2285 c = inchar (SCHEME_A);
2286
2329#if SHOW_ERROR_LINE 2287#if SHOW_ERROR_LINE
2330 if (c == '\n') 2288 if (ecb_expect_false (c == '\n'))
2331 curr_line++; 2289 curr_line++;
2332#endif 2290#endif
2291
2292 if (ecb_expect_false (c == EOF))
2293 return c;
2333 } 2294 }
2334 while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); 2295 while (is_one_of (WHITESPACE, c));
2335 2296
2336 /* record it */ 2297 /* record it */
2337#if SHOW_ERROR_LINE 2298#if SHOW_ERROR_LINE
2338 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) 2299 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2339 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line; 2300 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
2340#endif 2301#endif
2341 2302
2342 if (c != EOF)
2343 {
2344 backchar (SCHEME_A_ c); 2303 backchar (SCHEME_A_ c);
2345 return 1; 2304 return 1;
2346 }
2347 else
2348 return EOF;
2349} 2305}
2350 2306
2351/* get token */ 2307/* get token */
2352static int 2308ecb_cold static int
2353token (SCHEME_P) 2309token (SCHEME_P)
2354{ 2310{
2355 int c = skipspace (SCHEME_A); 2311 int c = skipspace (SCHEME_A);
2356 2312
2357 if (c == EOF) 2313 if (c == EOF)
… …
2369 return TOK_RPAREN; 2325 return TOK_RPAREN;
2370 2326
2371 case '.': 2327 case '.':
2372 c = inchar (SCHEME_A); 2328 c = inchar (SCHEME_A);
2373 2329
2374 if (is_one_of (" \n\t", c)) 2330 if (is_one_of (WHITESPACE, c))
2375 return TOK_DOT; 2331 return TOK_DOT;
2376 else 2332 else
2377 { 2333 {
2378 //TODO: ungetc twice in a row is not supported in C
2379 backchar (SCHEME_A_ c); 2334 backchar (SCHEME_A_ c);
2380 backchar (SCHEME_A_ '.');
2381 return TOK_ATOM; 2335 return TOK_DOTATOM;
2382 } 2336 }
2337
2338 case '|':
2339 return TOK_STRATOM;
2383 2340
2384 case '\'': 2341 case '\'':
2385 return TOK_QUOTE; 2342 return TOK_QUOTE;
2386 2343
2387 case ';': 2344 case ';':
… …
2454} 2411}
2455 2412
2456/* ========== Routines for Printing ========== */ 2413/* ========== Routines for Printing ========== */
2457#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2414#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2458 2415
2459static void 2416ecb_cold static void
2460printslashstring (SCHEME_P_ char *p, int len) 2417printslashstring (SCHEME_P_ char *p, int len)
2461{ 2418{
2462 int i; 2419 int i;
2463 unsigned char *s = (unsigned char *) p; 2420 unsigned char *s = (unsigned char *) p;
2464 2421
… …
2519 } 2476 }
2520 2477
2521 putcharacter (SCHEME_A_ '"'); 2478 putcharacter (SCHEME_A_ '"');
2522} 2479}
2523 2480
2524
2525/* print atoms */ 2481/* print atoms */
2526static void 2482ecb_cold static void
2527printatom (SCHEME_P_ pointer l, int f) 2483printatom (SCHEME_P_ pointer l, int f)
2528{ 2484{
2529 char *p; 2485 char *p;
2530 int len; 2486 int len;
2531 2487
2532 atom2str (SCHEME_A_ l, f, &p, &len); 2488 atom2str (SCHEME_A_ l, f, &p, &len);
2533 putchars (SCHEME_A_ p, len); 2489 putchars (SCHEME_A_ p, len);
2534} 2490}
2535 2491
2536
2537/* Uses internal buffer unless string pointer is already available */ 2492/* Uses internal buffer unless string pointer is already available */
2538static void 2493ecb_cold static void
2539atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2494atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2540{ 2495{
2541 char *p; 2496 char *p;
2542 2497
2543 if (l == NIL) 2498 if (l == NIL)
… …
2554 { 2509 {
2555 p = SCHEME_V->strbuff; 2510 p = SCHEME_V->strbuff;
2556 2511
2557 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ 2512 if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */
2558 { 2513 {
2559 if (num_is_integer (l)) 2514 if (is_integer (l))
2560 xnum (p, ivalue_unchecked (l)); 2515 xnum (p, ivalue_unchecked (l));
2561#if USE_FLOAT 2516#if USE_REAL
2562 else 2517 else
2563 { 2518 {
2564 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); 2519 snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l));
2565 /* r5rs says there must be a '.' (unless 'e'?) */ 2520 /* r5rs says there must be a '.' (unless 'e'?) */
2566 f = strcspn (p, ".e"); 2521 f = strcspn (p, ".e");
… …
2701#endif 2656#endif
2702 } 2657 }
2703 else if (is_continuation (l)) 2658 else if (is_continuation (l))
2704 p = "#<CONTINUATION>"; 2659 p = "#<CONTINUATION>";
2705 else 2660 else
2661 {
2662#if USE_PRINTF
2663 p = SCHEME_V->strbuff;
2664 snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
2665#else
2706 p = "#<ERROR>"; 2666 p = "#<ERROR>";
2667#endif
2668 }
2707 2669
2708 *pp = p; 2670 *pp = p;
2709 *plen = strlen (p); 2671 *plen = strlen (p);
2710} 2672}
2711 2673
… …
2743 return car (d); 2705 return car (d);
2744 2706
2745 p = cons (car (d), cdr (d)); 2707 p = cons (car (d), cdr (d));
2746 q = p; 2708 q = p;
2747 2709
2748 while (cdr (cdr (p)) != NIL) 2710 while (cddr (p) != NIL)
2749 { 2711 {
2750 d = cons (car (p), cdr (p)); 2712 d = cons (car (p), cdr (p));
2751 2713
2752 if (cdr (cdr (p)) != NIL) 2714 if (cddr (p) != NIL)
2753 p = cdr (d); 2715 p = cdr (d);
2754 } 2716 }
2755 2717
2756 set_cdr (p, car (cdr (p))); 2718 set_cdr (p, cadr (p));
2757 return q; 2719 return q;
2758} 2720}
2759 2721
2760/* reverse list -- produce new list */ 2722/* reverse list -- produce new list */
2761static pointer 2723ecb_hot static pointer
2762reverse (SCHEME_P_ pointer a) 2724reverse (SCHEME_P_ pointer a)
2763{ 2725{
2764 /* a must be checked by gc */ 2726 /* a must be checked by gc */
2765 pointer p = NIL; 2727 pointer p = NIL;
2766 2728
… …
2769 2731
2770 return p; 2732 return p;
2771} 2733}
2772 2734
2773/* reverse list --- in-place */ 2735/* reverse list --- in-place */
2774static pointer 2736ecb_hot static pointer
2775reverse_in_place (SCHEME_P_ pointer term, pointer list) 2737reverse_in_place (SCHEME_P_ pointer term, pointer list)
2776{ 2738{
2777 pointer result = term; 2739 pointer result = term;
2778 pointer p = list; 2740 pointer p = list;
2779 2741
… …
2787 2749
2788 return result; 2750 return result;
2789} 2751}
2790 2752
2791/* append list -- produce new list (in reverse order) */ 2753/* append list -- produce new list (in reverse order) */
2792static pointer 2754ecb_hot static pointer
2793revappend (SCHEME_P_ pointer a, pointer b) 2755revappend (SCHEME_P_ pointer a, pointer b)
2794{ 2756{
2795 pointer result = a; 2757 pointer result = a;
2796 pointer p = b; 2758 pointer p = b;
2797 2759
… …
2806 2768
2807 return S_F; /* signal an error */ 2769 return S_F; /* signal an error */
2808} 2770}
2809 2771
2810/* equivalence of atoms */ 2772/* equivalence of atoms */
2811int 2773ecb_hot int
2812eqv (pointer a, pointer b) 2774eqv (pointer a, pointer b)
2813{ 2775{
2814 if (is_string (a)) 2776 if (is_string (a))
2815 { 2777 {
2816 if (is_string (b)) 2778 if (is_string (b))
… …
2819 return 0; 2781 return 0;
2820 } 2782 }
2821 else if (is_number (a)) 2783 else if (is_number (a))
2822 { 2784 {
2823 if (is_number (b)) 2785 if (is_number (b))
2824 if (num_is_integer (a) == num_is_integer (b))
2825 return num_eq (nvalue (a), nvalue (b)); 2786 return num_cmp (nvalue (a), nvalue (b)) == 0;
2826 2787
2827 return 0; 2788 return 0;
2828 } 2789 }
2829 else if (is_character (a)) 2790 else if (is_character (a))
2830 { 2791 {
… …
2856/* () is #t in R5RS */ 2817/* () is #t in R5RS */
2857#define is_true(p) ((p) != S_F) 2818#define is_true(p) ((p) != S_F)
2858#define is_false(p) ((p) == S_F) 2819#define is_false(p) ((p) == S_F)
2859 2820
2860/* ========== Environment implementation ========== */ 2821/* ========== Environment implementation ========== */
2861
2862#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
2863
2864static int
2865hash_fn (const char *key, int table_size)
2866{
2867 const unsigned char *p = key;
2868 uint32_t hash = 2166136261;
2869
2870 while (*p)
2871 hash = (hash ^ *p++) * 16777619;
2872
2873 return hash % table_size;
2874}
2875#endif
2876 2822
2877#ifndef USE_ALIST_ENV 2823#ifndef USE_ALIST_ENV
2878 2824
2879/* 2825/*
2880 * In this implementation, each frame of the environment may be 2826 * In this implementation, each frame of the environment may be
… …
2897 2843
2898 SCHEME_V->envir = immutable_cons (new_frame, old_env); 2844 SCHEME_V->envir = immutable_cons (new_frame, old_env);
2899 setenvironment (SCHEME_V->envir); 2845 setenvironment (SCHEME_V->envir);
2900} 2846}
2901 2847
2902static INLINE void 2848static uint32_t
2849sym_hash (pointer sym, uint32_t size)
2850{
2851 uintptr_t ptr = (uintptr_t)sym;
2852
2853#if 0
2854 /* table size is prime, so why mix */
2855 ptr += ptr >> 32;
2856 ptr += ptr >> 16;
2857 ptr += ptr >> 8;
2858#endif
2859
2860 return ptr % size;
2861}
2862
2863ecb_inline void
2903new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2864new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2904{ 2865{
2905 pointer slot = immutable_cons (variable, value); 2866 pointer slot = immutable_cons (variable, value);
2906 2867
2907 if (is_vector (car (env))) 2868 if (is_vector (car (env)))
2908 { 2869 {
2909 int location = hash_fn (symname (variable), vector_length (car (env))); 2870 int location = sym_hash (variable, veclength (car (env)));
2910
2911 set_vector_elem (car (env), location, immutable_cons (slot, vector_elem (car (env), location))); 2871 vector_set (car (env), location, immutable_cons (slot, vector_get (car (env), location)));
2912 } 2872 }
2913 else 2873 else
2914 set_car (env, immutable_cons (slot, car (env))); 2874 set_car (env, immutable_cons (slot, car (env)));
2915} 2875}
2916 2876
2917static pointer 2877ecb_hot static pointer
2918find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2878find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2919{ 2879{
2920 pointer x, y; 2880 pointer x, y;
2921 int location;
2922 2881
2923 for (x = env; x != NIL; x = cdr (x)) 2882 for (x = env; x != NIL; x = cdr (x))
2924 { 2883 {
2925 if (is_vector (car (x))) 2884 if (is_vector (car (x)))
2926 { 2885 {
2927 location = hash_fn (symname (hdl), vector_length (car (x))); 2886 int location = sym_hash (hdl, veclength (car (x)));
2928 y = vector_elem (car (x), location); 2887 y = vector_get (car (x), location);
2929 } 2888 }
2930 else 2889 else
2931 y = car (x); 2890 y = car (x);
2932 2891
2933 for (; y != NIL; y = cdr (y)) 2892 for (; y != NIL; y = cdr (y))
2934 if (caar (y) == hdl) 2893 if (caar (y) == hdl)
2935 break; 2894 break;
2936 2895
2937 if (y != NIL) 2896 if (y != NIL)
2897 return car (y);
2898
2899 if (!all)
2938 break; 2900 break;
2939
2940 if (!all)
2941 return NIL;
2942 } 2901 }
2943
2944 if (x != NIL)
2945 return car (y);
2946 2902
2947 return NIL; 2903 return NIL;
2948} 2904}
2949 2905
2950#else /* USE_ALIST_ENV */ 2906#else /* USE_ALIST_ENV */
2951 2907
2952static INLINE void 2908static void
2953new_frame_in_env (SCHEME_P_ pointer old_env) 2909new_frame_in_env (SCHEME_P_ pointer old_env)
2954{ 2910{
2955 SCHEME_V->envir = immutable_cons (NIL, old_env); 2911 SCHEME_V->envir = immutable_cons (NIL, old_env);
2956 setenvironment (SCHEME_V->envir); 2912 setenvironment (SCHEME_V->envir);
2957} 2913}
2958 2914
2959static INLINE void 2915static void
2960new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2916new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2961{ 2917{
2962 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2918 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2963} 2919}
2964 2920
2965static pointer 2921ecb_hot static pointer
2966find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2922find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2967{ 2923{
2968 pointer x, y; 2924 pointer x, y;
2969 2925
2970 for (x = env; x != NIL; x = cdr (x)) 2926 for (x = env; x != NIL; x = cdr (x))
… …
2972 for (y = car (x); y != NIL; y = cdr (y)) 2928 for (y = car (x); y != NIL; y = cdr (y))
2973 if (caar (y) == hdl) 2929 if (caar (y) == hdl)
2974 break; 2930 break;
2975 2931
2976 if (y != NIL) 2932 if (y != NIL)
2933 return car (y);
2977 break; 2934 break;
2978 2935
2979 if (!all) 2936 if (!all)
2980 return NIL; 2937 break;
2981 } 2938 }
2982
2983 if (x != NIL)
2984 return car (y);
2985 2939
2986 return NIL; 2940 return NIL;
2987} 2941}
2988 2942
2989#endif /* USE_ALIST_ENV else */ 2943#endif /* USE_ALIST_ENV else */
2990 2944
2991static INLINE void 2945static void
2992new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2946new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2993{ 2947{
2948 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2994 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2949 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2995} 2950}
2996 2951
2997static INLINE void 2952static void
2998set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2953set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2999{ 2954{
3000 set_cdr (slot, value); 2955 set_cdr (slot, value);
3001} 2956}
3002 2957
3003static INLINE pointer 2958static pointer
3004slot_value_in_env (pointer slot) 2959slot_value_in_env (pointer slot)
3005{ 2960{
3006 return cdr (slot); 2961 return cdr (slot);
3007} 2962}
3008 2963
3009/* ========== Evaluation Cycle ========== */ 2964/* ========== Evaluation Cycle ========== */
3010 2965
3011static pointer 2966ecb_cold static int
3012xError_1 (SCHEME_P_ const char *s, pointer a) 2967xError_1 (SCHEME_P_ const char *s, pointer a)
3013{ 2968{
3014#if USE_ERROR_HOOK 2969#if USE_ERROR_HOOK
3015 pointer x; 2970 pointer x;
3016 pointer hdl = SCHEME_V->ERROR_HOOK; 2971 pointer hdl = SCHEME_V->ERROR_HOOK;
… …
3042#if USE_ERROR_HOOK 2997#if USE_ERROR_HOOK
3043 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 2998 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1);
3044 2999
3045 if (x != NIL) 3000 if (x != NIL)
3046 { 3001 {
3047 if (a) 3002 pointer code = a
3048 SCHEME_V->code = cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL); 3003 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
3049 else 3004 : NIL;
3050 SCHEME_V->code = NIL;
3051 3005
3052 SCHEME_V->code = cons (mk_string (SCHEME_A_ s), SCHEME_V->code); 3006 code = cons (mk_string (SCHEME_A_ s), code);
3053 setimmutable (car (SCHEME_V->code)); 3007 setimmutable (car (code));
3054 SCHEME_V->code = cons (slot_value_in_env (x), SCHEME_V->code); 3008 SCHEME_V->code = cons (slot_value_in_env (x), code);
3055 SCHEME_V->op = OP_EVAL; 3009 SCHEME_V->op = OP_EVAL;
3056 3010
3057 return S_T; 3011 return 0;
3058 } 3012 }
3059#endif 3013#endif
3060 3014
3061 if (a) 3015 if (a)
3062 SCHEME_V->args = cons (a, NIL); 3016 SCHEME_V->args = cons (a, NIL);
… …
3064 SCHEME_V->args = NIL; 3018 SCHEME_V->args = NIL;
3065 3019
3066 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args); 3020 SCHEME_V->args = cons (mk_string (SCHEME_A_ s), SCHEME_V->args);
3067 setimmutable (car (SCHEME_V->args)); 3021 setimmutable (car (SCHEME_V->args));
3068 SCHEME_V->op = OP_ERR0; 3022 SCHEME_V->op = OP_ERR0;
3023
3069 return S_T; 3024 return 0;
3070} 3025}
3071 3026
3072#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a) 3027#define Error_1(s, a) return xError_1(SCHEME_A_ USE_ERROR_CHECKING ? s : "", a)
3073#define Error_0(s) Error_1 (s, 0) 3028#define Error_0(s) Error_1 (s, 0)
3074 3029
3075/* Too small to turn into function */ 3030/* Too small to turn into function */
3076#define BEGIN do { 3031#define BEGIN do {
3077#define END } while (0) 3032#define END } while (0)
3078#define s_goto(a) BEGIN \ 3033#define s_goto(a) BEGIN \
3079 SCHEME_V->op = a; \ 3034 SCHEME_V->op = a; \
3080 return S_T; END 3035 return 0; END
3081 3036
3082#define s_return(a) return xs_return (SCHEME_A_ a) 3037#define s_return(a) return xs_return (SCHEME_A_ a)
3083 3038
3084#ifndef USE_SCHEME_STACK 3039#ifndef USE_SCHEME_STACK
3085 3040
… …
3092 pointer code; 3047 pointer code;
3093}; 3048};
3094 3049
3095# define STACK_GROWTH 3 3050# define STACK_GROWTH 3
3096 3051
3097static void 3052ecb_hot static void
3098s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3053s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3099{ 3054{
3100 int nframes = (uintptr_t)SCHEME_V->dump; 3055 int nframes = (uintptr_t)SCHEME_V->dump;
3101 struct dump_stack_frame *next_frame; 3056 struct dump_stack_frame *next_frame;
3102 3057
3103 /* enough room for the next frame? */ 3058 /* enough room for the next frame? */
3104 if (nframes >= SCHEME_V->dump_size) 3059 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3105 { 3060 {
3106 SCHEME_V->dump_size += STACK_GROWTH; 3061 SCHEME_V->dump_size += STACK_GROWTH;
3107 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); 3062 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3108 } 3063 }
3109 3064
3110 next_frame = SCHEME_V->dump_base + nframes; 3065 next_frame = SCHEME_V->dump_base + nframes;
3111 3066
3112 next_frame->op = op; 3067 next_frame->op = op;
3113 next_frame->args = args; 3068 next_frame->args = args;
3114 next_frame->envir = SCHEME_V->envir; 3069 next_frame->envir = SCHEME_V->envir;
3115 next_frame->code = code; 3070 next_frame->code = code;
3116 3071
3117 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3072 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3118} 3073}
3119 3074
3120static pointer 3075static ecb_hot int
3121xs_return (SCHEME_P_ pointer a) 3076xs_return (SCHEME_P_ pointer a)
3122{ 3077{
3123 int nframes = (uintptr_t)SCHEME_V->dump; 3078 int nframes = (uintptr_t)SCHEME_V->dump;
3124 struct dump_stack_frame *frame; 3079 struct dump_stack_frame *frame;
3125 3080
3126 SCHEME_V->value = a; 3081 SCHEME_V->value = a;
3127 3082
3128 if (nframes <= 0) 3083 if (nframes <= 0)
3129 return NIL; 3084 return -1;
3130 3085
3131 frame = &SCHEME_V->dump_base[--nframes]; 3086 frame = &SCHEME_V->dump_base[--nframes];
3132 SCHEME_V->op = frame->op; 3087 SCHEME_V->op = frame->op;
3133 SCHEME_V->args = frame->args; 3088 SCHEME_V->args = frame->args;
3134 SCHEME_V->envir = frame->envir; 3089 SCHEME_V->envir = frame->envir;
3135 SCHEME_V->code = frame->code; 3090 SCHEME_V->code = frame->code;
3136 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3091 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3137 3092
3138 return S_T; 3093 return 0;
3139} 3094}
3140 3095
3141static INLINE void 3096ecb_cold void
3142dump_stack_reset (SCHEME_P) 3097dump_stack_reset (SCHEME_P)
3143{ 3098{
3144 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3099 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3145 SCHEME_V->dump = (pointer)+0; 3100 SCHEME_V->dump = (pointer)+0;
3146} 3101}
3147 3102
3148static INLINE void 3103ecb_cold void
3149dump_stack_initialize (SCHEME_P) 3104dump_stack_initialize (SCHEME_P)
3150{ 3105{
3151 SCHEME_V->dump_size = 0; 3106 SCHEME_V->dump_size = 0;
3152 SCHEME_V->dump_base = 0; 3107 SCHEME_V->dump_base = 0;
3153 dump_stack_reset (SCHEME_A); 3108 dump_stack_reset (SCHEME_A);
3154} 3109}
3155 3110
3156static void 3111ecb_cold static void
3157dump_stack_free (SCHEME_P) 3112dump_stack_free (SCHEME_P)
3158{ 3113{
3159 free (SCHEME_V->dump_base); 3114 free (SCHEME_V->dump_base);
3160 SCHEME_V->dump_base = 0; 3115 SCHEME_V->dump_base = 0;
3161 SCHEME_V->dump = (pointer)0; 3116 SCHEME_V->dump = (pointer)0;
3162 SCHEME_V->dump_size = 0; 3117 SCHEME_V->dump_size = 0;
3163} 3118}
3164 3119
3165static void 3120ecb_cold static void
3166dump_stack_mark (SCHEME_P) 3121dump_stack_mark (SCHEME_P)
3167{ 3122{
3168 int nframes = (uintptr_t)SCHEME_V->dump; 3123 int nframes = (uintptr_t)SCHEME_V->dump;
3169 int i; 3124 int i;
3170 3125
… …
3176 mark (frame->envir); 3131 mark (frame->envir);
3177 mark (frame->code); 3132 mark (frame->code);
3178 } 3133 }
3179} 3134}
3180 3135
3181static pointer 3136ecb_cold static pointer
3182ss_get_cont (SCHEME_P) 3137ss_get_cont (SCHEME_P)
3183{ 3138{
3184 int nframes = (uintptr_t)SCHEME_V->dump; 3139 int nframes = (uintptr_t)SCHEME_V->dump;
3185 int i; 3140 int i;
3186 3141
… …
3198 } 3153 }
3199 3154
3200 return cont; 3155 return cont;
3201} 3156}
3202 3157
3203static void 3158ecb_cold static void
3204ss_set_cont (SCHEME_P_ pointer cont) 3159ss_set_cont (SCHEME_P_ pointer cont)
3205{ 3160{
3206 int i = 0; 3161 int i = 0;
3207 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3162 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3208 3163
3209 while (cont != NIL) 3164 while (cont != NIL)
3210 { 3165 {
3211 frame->op = ivalue (car (cont)); cont = cdr (cont); 3166 frame->op = ivalue_unchecked (car (cont)); cont = cdr (cont);
3212 frame->args = car (cont) ; cont = cdr (cont); 3167 frame->args = car (cont) ; cont = cdr (cont);
3213 frame->envir = car (cont) ; cont = cdr (cont); 3168 frame->envir = car (cont) ; cont = cdr (cont);
3214 frame->code = car (cont) ; cont = cdr (cont); 3169 frame->code = car (cont) ; cont = cdr (cont);
3215 3170
3216 ++frame; 3171 ++frame;
3217 ++i; 3172 ++i;
3218 } 3173 }
3219 3174
3220 SCHEME_V->dump = (pointer)(uintptr_t)i; 3175 SCHEME_V->dump = (pointer)(uintptr_t)i;
3221} 3176}
3222 3177
3223#else 3178#else
3224 3179
3225static INLINE void 3180ecb_cold void
3226dump_stack_reset (SCHEME_P) 3181dump_stack_reset (SCHEME_P)
3227{ 3182{
3228 SCHEME_V->dump = NIL; 3183 SCHEME_V->dump = NIL;
3229} 3184}
3230 3185
3231static INLINE void 3186ecb_cold void
3232dump_stack_initialize (SCHEME_P) 3187dump_stack_initialize (SCHEME_P)
3233{ 3188{
3234 dump_stack_reset (SCHEME_A); 3189 dump_stack_reset (SCHEME_A);
3235} 3190}
3236 3191
3237static void 3192ecb_cold static void
3238dump_stack_free (SCHEME_P) 3193dump_stack_free (SCHEME_P)
3239{ 3194{
3240 SCHEME_V->dump = NIL; 3195 SCHEME_V->dump = NIL;
3241} 3196}
3242 3197
3243static pointer 3198ecb_hot static int
3244xs_return (SCHEME_P_ pointer a) 3199xs_return (SCHEME_P_ pointer a)
3245{ 3200{
3246 pointer dump = SCHEME_V->dump; 3201 pointer dump = SCHEME_V->dump;
3247 3202
3248 SCHEME_V->value = a; 3203 SCHEME_V->value = a;
3249 3204
3250 if (dump == NIL) 3205 if (dump == NIL)
3251 return NIL; 3206 return -1;
3252 3207
3253 SCHEME_V->op = ivalue (car (dump)); dump = cdr (dump); 3208 SCHEME_V->op = ivalue_unchecked (car (dump)); dump = cdr (dump);
3254 SCHEME_V->args = car (dump) ; dump = cdr (dump); 3209 SCHEME_V->args = car (dump) ; dump = cdr (dump);
3255 SCHEME_V->envir = car (dump) ; dump = cdr (dump); 3210 SCHEME_V->envir = car (dump) ; dump = cdr (dump);
3256 SCHEME_V->code = car (dump) ; dump = cdr (dump); 3211 SCHEME_V->code = car (dump) ; dump = cdr (dump);
3257 3212
3258 SCHEME_V->dump = dump; 3213 SCHEME_V->dump = dump;
3259 3214
3260 return S_T; 3215 return 0;
3261} 3216}
3262 3217
3263static void 3218ecb_hot static void
3264s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3219s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3265{ 3220{
3266 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3221 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3267 cons (args, 3222 cons (args,
3268 cons (SCHEME_V->envir, 3223 cons (SCHEME_V->envir,
3269 cons (code, 3224 cons (code,
3270 SCHEME_V->dump)))); 3225 SCHEME_V->dump))));
3271} 3226}
3272 3227
3273static void 3228ecb_cold static void
3274dump_stack_mark (SCHEME_P) 3229dump_stack_mark (SCHEME_P)
3275{ 3230{
3276 mark (SCHEME_V->dump); 3231 mark (SCHEME_V->dump);
3277} 3232}
3278 3233
3279static pointer 3234ecb_cold static pointer
3280ss_get_cont (SCHEME_P) 3235ss_get_cont (SCHEME_P)
3281{ 3236{
3282 return SCHEME_V->dump; 3237 return SCHEME_V->dump;
3283} 3238}
3284 3239
3285static void 3240ecb_cold static void
3286ss_set_cont (SCHEME_P_ pointer cont) 3241ss_set_cont (SCHEME_P_ pointer cont)
3287{ 3242{
3288 SCHEME_V->dump = cont; 3243 SCHEME_V->dump = cont;
3289} 3244}
3290 3245
3291#endif 3246#endif
3292 3247
3293#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3248#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3294 3249
3250#if EXPERIMENT
3295static pointer 3251static int
3252debug (SCHEME_P_ int indent, pointer x)
3253{
3254 int c;
3255
3256 if (is_syntax (x))
3257 {
3258 printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
3259 return 8 + 8;
3260 }
3261
3262 if (x == NIL)
3263 {
3264 printf ("%*sNIL\n", indent, "");
3265 return 3;
3266 }
3267
3268 switch (type (x))
3269 {
3270 case T_INTEGER:
3271 printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
3272 return 32+8;
3273
3274 case T_SYMBOL:
3275 printf ("%*sS<%s>\n", indent, "", symname (x));
3276 return 24+8;
3277
3278 case T_CLOSURE:
3279 printf ("%*sS<%s>\n", indent, "", "closure");
3280 debug (SCHEME_A_ indent + 3, cdr(x));
3281 return 32 + debug (SCHEME_A_ indent + 3, car (x));
3282
3283 case T_PAIR:
3284 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3285 c = debug (SCHEME_A_ indent + 3, car (x));
3286 c += debug (SCHEME_A_ indent + 3, cdr (x));
3287 return c + 1;
3288
3289 case T_PORT:
3290 printf ("%*sS<%s>\n", indent, "", "port");
3291 return 24+8;
3292
3293 case T_VECTOR:
3294 printf ("%*sS<%s>\n", indent, "", "vector");
3295 return 24+8;
3296
3297 case T_ENVIRONMENT:
3298 printf ("%*sS<%s>\n", indent, "", "environment");
3299 return 0 + debug (SCHEME_A_ indent + 3, car (x));
3300
3301 default:
3302 printf ("unhandled type %d\n", type (x));
3303 break;
3304 }
3305}
3306#endif
3307
3308/* syntax, eval, core, ... */
3309ecb_hot static int
3296opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3310opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3297{ 3311{
3312 pointer args = SCHEME_V->args;
3298 pointer x, y; 3313 pointer x, y;
3299 3314
3300 switch (op) 3315 switch (op)
3301 { 3316 {
3317#if EXPERIMENT //D
3318 case OP_DEBUG:
3319 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
3320 printf ("\n");
3321 s_return (S_T);
3322#endif
3302 case OP_LOAD: /* load */ 3323 case OP_LOAD: /* load */
3303 if (file_interactive (SCHEME_A)) 3324 if (file_interactive (SCHEME_A))
3304 { 3325 {
3305 xwrstr ("Loading "); xwrstr (strvalue (car (SCHEME_V->args))); xwrstr ("\n"); 3326 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
3306 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (SCHEME_V->args))); 3327 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3307 } 3328 }
3308 3329
3309 if (!file_push (SCHEME_A_ strvalue (car (SCHEME_V->args)))) 3330 if (!file_push (SCHEME_A_ strvalue (car (args))))
3310 Error_1 ("unable to open", car (SCHEME_V->args)); 3331 Error_1 ("unable to open", car (args));
3311 else 3332 else
3312 { 3333 {
3313 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3334 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3314 s_goto (OP_T0LVL); 3335 s_goto (OP_T0LVL);
3315 } 3336 }
3316 3337
3317 case OP_T0LVL: /* top level */ 3338 case OP_T0LVL: /* top level */
3318 3339
3319 /* If we reached the end of file, this loop is done. */ 3340 /* If we reached the end of file, this loop is done. */
3320 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3341 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3321 { 3342 {
3322 if (SCHEME_V->file_i == 0) 3343 if (SCHEME_V->file_i == 0)
3323 { 3344 {
3324 SCHEME_V->args = NIL; 3345 SCHEME_V->args = NIL;
3325 s_goto (OP_QUIT); 3346 s_goto (OP_QUIT);
… …
3350 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL); 3371 s_save (SCHEME_A_ OP_VALUEPRINT, NIL, NIL);
3351 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL); 3372 s_save (SCHEME_A_ OP_T1LVL, NIL, NIL);
3352 s_goto (OP_READ_INTERNAL); 3373 s_goto (OP_READ_INTERNAL);
3353 3374
3354 case OP_T1LVL: /* top level */ 3375 case OP_T1LVL: /* top level */
3355 SCHEME_V->code = SCHEME_V->value; 3376 SCHEME_V->code = SCHEME_V->value;
3356 SCHEME_V->inport = SCHEME_V->save_inport; 3377 SCHEME_V->inport = SCHEME_V->save_inport;
3357 s_goto (OP_EVAL); 3378 s_goto (OP_EVAL);
3358 3379
3359 case OP_READ_INTERNAL: /* internal read */ 3380 case OP_READ_INTERNAL: /* internal read */
3360 SCHEME_V->tok = token (SCHEME_A); 3381 SCHEME_V->tok = token (SCHEME_A);
… …
3389 case OP_EVAL: /* main part of evaluation */ 3410 case OP_EVAL: /* main part of evaluation */
3390#if USE_TRACING 3411#if USE_TRACING
3391 if (SCHEME_V->tracing) 3412 if (SCHEME_V->tracing)
3392 { 3413 {
3393 /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */ 3414 /*s_save(SCHEME_A_ OP_VALUEPRINT,NIL,NIL); */
3394 s_save (SCHEME_A_ OP_REAL_EVAL, SCHEME_V->args, SCHEME_V->code); 3415 s_save (SCHEME_A_ OP_REAL_EVAL, args, SCHEME_V->code);
3395 SCHEME_V->args = SCHEME_V->code; 3416 SCHEME_V->args = SCHEME_V->code;
3396 putstr (SCHEME_A_ "\nEval: "); 3417 putstr (SCHEME_A_ "\nEval: ");
3397 s_goto (OP_P0LIST); 3418 s_goto (OP_P0LIST);
3398 } 3419 }
3399 3420
… …
3403#endif 3424#endif
3404 if (is_symbol (SCHEME_V->code)) /* symbol */ 3425 if (is_symbol (SCHEME_V->code)) /* symbol */
3405 { 3426 {
3406 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3427 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3407 3428
3408 if (x != NIL) 3429 if (x == NIL)
3409 s_return (slot_value_in_env (x));
3410 else
3411 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3430 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3431
3432 s_return (slot_value_in_env (x));
3412 } 3433 }
3413 else if (is_pair (SCHEME_V->code)) 3434 else if (is_pair (SCHEME_V->code))
3414 { 3435 {
3436 x = car (SCHEME_V->code);
3437
3415 if (is_syntax (x = car (SCHEME_V->code))) /* SYNTAX */ 3438 if (is_syntax (x)) /* SYNTAX */
3416 { 3439 {
3417 SCHEME_V->code = cdr (SCHEME_V->code); 3440 SCHEME_V->code = cdr (SCHEME_V->code);
3418 s_goto (syntaxnum (x)); 3441 s_goto (syntaxnum (x));
3419 } 3442 }
3420 else /* first, eval top element and eval arguments */ 3443 else /* first, eval top element and eval arguments */
3421 { 3444 {
3422 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code); 3445 s_save (SCHEME_A_ OP_E0ARGS, NIL, SCHEME_V->code);
3423 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3446 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3424 SCHEME_V->code = car (SCHEME_V->code); 3447 SCHEME_V->code = x;
3425 s_goto (OP_EVAL); 3448 s_goto (OP_EVAL);
3426 } 3449 }
3427 } 3450 }
3428 else 3451 else
3429 s_return (SCHEME_V->code); 3452 s_return (SCHEME_V->code);
3430 3453
3431 case OP_E0ARGS: /* eval arguments */ 3454 case OP_E0ARGS: /* eval arguments */
3432 if (is_macro (SCHEME_V->value)) /* macro expansion */ 3455 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3433 { 3456 {
3434 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3457 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3435 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3458 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3436 SCHEME_V->code = SCHEME_V->value; 3459 SCHEME_V->code = SCHEME_V->value;
3437 s_goto (OP_APPLY); 3460 s_goto (OP_APPLY);
… …
3441 SCHEME_V->code = cdr (SCHEME_V->code); 3464 SCHEME_V->code = cdr (SCHEME_V->code);
3442 s_goto (OP_E1ARGS); 3465 s_goto (OP_E1ARGS);
3443 } 3466 }
3444 3467
3445 case OP_E1ARGS: /* eval arguments */ 3468 case OP_E1ARGS: /* eval arguments */
3446 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3469 args = cons (SCHEME_V->value, args);
3447 3470
3448 if (is_pair (SCHEME_V->code)) /* continue */ 3471 if (is_pair (SCHEME_V->code)) /* continue */
3449 { 3472 {
3450 s_save (SCHEME_A_ OP_E1ARGS, SCHEME_V->args, cdr (SCHEME_V->code)); 3473 s_save (SCHEME_A_ OP_E1ARGS, args, cdr (SCHEME_V->code));
3451 SCHEME_V->code = car (SCHEME_V->code); 3474 SCHEME_V->code = car (SCHEME_V->code);
3452 SCHEME_V->args = NIL; 3475 SCHEME_V->args = NIL;
3453 s_goto (OP_EVAL); 3476 s_goto (OP_EVAL);
3454 } 3477 }
3455 else /* end */ 3478 else /* end */
3456 { 3479 {
3457 SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); 3480 args = reverse_in_place (SCHEME_A_ NIL, args);
3458 SCHEME_V->code = car (SCHEME_V->args); 3481 SCHEME_V->code = car (args);
3459 SCHEME_V->args = cdr (SCHEME_V->args); 3482 SCHEME_V->args = cdr (args);
3460 s_goto (OP_APPLY); 3483 s_goto (OP_APPLY);
3461 } 3484 }
3462 3485
3463#if USE_TRACING 3486#if USE_TRACING
3464 3487
3465 case OP_TRACING: 3488 case OP_TRACING:
3466 { 3489 {
3467 int tr = SCHEME_V->tracing; 3490 int tr = SCHEME_V->tracing;
3468 3491
3469 SCHEME_V->tracing = ivalue (car (SCHEME_V->args)); 3492 SCHEME_V->tracing = ivalue_unchecked (car (args));
3470 s_return (mk_integer (SCHEME_A_ tr)); 3493 s_return (mk_integer (SCHEME_A_ tr));
3471 } 3494 }
3472 3495
3473#endif 3496#endif
3474 3497
3475 case OP_APPLY: /* apply 'code' to 'args' */ 3498 case OP_APPLY: /* apply 'code' to 'args' */
3476#if USE_TRACING 3499#if USE_TRACING
3477 if (SCHEME_V->tracing) 3500 if (SCHEME_V->tracing)
3478 { 3501 {
3479 s_save (SCHEME_A_ OP_REAL_APPLY, SCHEME_V->args, SCHEME_V->code); 3502 s_save (SCHEME_A_ OP_REAL_APPLY, args, SCHEME_V->code);
3480 SCHEME_V->print_flag = 1; 3503 SCHEME_V->print_flag = 1;
3481 /* SCHEME_V->args=cons(SCHEME_V->code,SCHEME_V->args); */ 3504 /* args=cons(SCHEME_V->code,args); */
3482 putstr (SCHEME_A_ "\nApply to: "); 3505 putstr (SCHEME_A_ "\nApply to: ");
3483 s_goto (OP_P0LIST); 3506 s_goto (OP_P0LIST);
3484 } 3507 }
3485 3508
3486 /* fall through */ 3509 /* fall through */
3487 3510
3488 case OP_REAL_APPLY: 3511 case OP_REAL_APPLY:
3489#endif 3512#endif
3490 if (is_proc (SCHEME_V->code)) 3513 if (is_proc (SCHEME_V->code))
3491 {
3492 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3514 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3493 }
3494 else if (is_foreign (SCHEME_V->code)) 3515 else if (is_foreign (SCHEME_V->code))
3495 { 3516 {
3496 /* Keep nested calls from GC'ing the arglist */ 3517 /* Keep nested calls from GC'ing the arglist */
3497 push_recent_alloc (SCHEME_A_ SCHEME_V->args, NIL); 3518 push_recent_alloc (SCHEME_A_ args, NIL);
3498 x = SCHEME_V->code->object.ff (SCHEME_A_ SCHEME_V->args); 3519 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3499 3520
3500 s_return (x); 3521 s_return (x);
3501 } 3522 }
3502 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3523 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3503 { 3524 {
3504 /* Should not accept promise */ 3525 /* Should not accept promise */
3505 /* make environment */ 3526 /* make environment */
3506 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code)); 3527 new_frame_in_env (SCHEME_A_ closure_env (SCHEME_V->code));
3507 3528
3508 for (x = car (closure_code (SCHEME_V->code)), y = SCHEME_V->args; is_pair (x); x = cdr (x), y = cdr (y)) 3529 for (x = car (closure_code (SCHEME_V->code)), y = args; is_pair (x); x = cdr (x), y = cdr (y))
3509 { 3530 {
3510 if (y == NIL) 3531 if (y == NIL)
3511 Error_0 ("not enough arguments"); 3532 Error_0 ("not enough arguments");
3512 else 3533 else
3513 new_slot_in_env (SCHEME_A_ car (x), car (y)); 3534 new_slot_in_env (SCHEME_A_ car (x), car (y));
… …
3531 s_goto (OP_BEGIN); 3552 s_goto (OP_BEGIN);
3532 } 3553 }
3533 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3554 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3534 { 3555 {
3535 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3556 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3536 s_return (SCHEME_V->args != NIL ? car (SCHEME_V->args) : NIL); 3557 s_return (args != NIL ? car (args) : NIL);
3537 } 3558 }
3538 else 3559 else
3539 Error_0 ("illegal function"); 3560 Error_0 ("illegal function");
3540 3561
3541 case OP_DOMACRO: /* do macro */ 3562 case OP_DOMACRO: /* do macro */
3542 SCHEME_V->code = SCHEME_V->value; 3563 SCHEME_V->code = SCHEME_V->value;
3543 s_goto (OP_EVAL); 3564 s_goto (OP_EVAL);
3544
3545#if 1
3546 3565
3547 case OP_LAMBDA: /* lambda */ 3566 case OP_LAMBDA: /* lambda */
3548 /* If the hook is defined, apply it to SCHEME_V->code, otherwise 3567 /* If the hook is defined, apply it to SCHEME_V->code, otherwise
3549 set SCHEME_V->value fall thru */ 3568 set SCHEME_V->value fall thru */
3550 { 3569 {
3551 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1); 3570 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1);
3552 3571
3553 if (f != NIL) 3572 if (f != NIL)
3554 { 3573 {
3555 s_save (SCHEME_A_ OP_LAMBDA1, SCHEME_V->args, SCHEME_V->code); 3574 s_save (SCHEME_A_ OP_LAMBDA1, args, SCHEME_V->code);
3556 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3575 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3557 SCHEME_V->code = slot_value_in_env (f); 3576 SCHEME_V->code = slot_value_in_env (f);
3558 s_goto (OP_APPLY); 3577 s_goto (OP_APPLY);
3559 } 3578 }
3560 3579
3561 SCHEME_V->value = SCHEME_V->code; 3580 SCHEME_V->value = SCHEME_V->code;
3562 /* Fallthru */
3563 } 3581 }
3582 /* Fallthru */
3564 3583
3565 case OP_LAMBDA1: 3584 case OP_LAMBDA1:
3566 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir)); 3585 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));
3567 3586
3568#else
3569
3570 case OP_LAMBDA: /* lambda */
3571 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3572
3573#endif
3574
3575 case OP_MKCLOSURE: /* make-closure */ 3587 case OP_MKCLOSURE: /* make-closure */
3576 x = car (SCHEME_V->args); 3588 x = car (args);
3577 3589
3578 if (car (x) == SCHEME_V->LAMBDA) 3590 if (car (x) == SCHEME_V->LAMBDA)
3579 x = cdr (x); 3591 x = cdr (x);
3580 3592
3581 if (cdr (SCHEME_V->args) == NIL) 3593 if (cdr (args) == NIL)
3582 y = SCHEME_V->envir; 3594 y = SCHEME_V->envir;
3583 else 3595 else
3584 y = cadr (SCHEME_V->args); 3596 y = cadr (args);
3585 3597
3586 s_return (mk_closure (SCHEME_A_ x, y)); 3598 s_return (mk_closure (SCHEME_A_ x, y));
3587 3599
3588 case OP_QUOTE: /* quote */ 3600 case OP_QUOTE: /* quote */
3589 s_return (car (SCHEME_V->code)); 3601 s_return (car (SCHEME_V->code));
… …
3621 3633
3622 3634
3623 case OP_DEFP: /* defined? */ 3635 case OP_DEFP: /* defined? */
3624 x = SCHEME_V->envir; 3636 x = SCHEME_V->envir;
3625 3637
3626 if (cdr (SCHEME_V->args) != NIL) 3638 if (cdr (args) != NIL)
3627 x = cadr (SCHEME_V->args); 3639 x = cadr (args);
3628 3640
3629 s_retbool (find_slot_in_env (SCHEME_A_ x, car (SCHEME_V->args), 1) != NIL); 3641 s_retbool (find_slot_in_env (SCHEME_A_ x, car (args), 1) != NIL);
3630 3642
3631 case OP_SET0: /* set! */ 3643 case OP_SET0: /* set! */
3632 if (is_immutable (car (SCHEME_V->code))) 3644 if (is_immutable (car (SCHEME_V->code)))
3633 Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code)); 3645 Error_1 ("set!: unable to alter immutable variable", car (SCHEME_V->code));
3634 3646
… …
3665 3677
3666 case OP_IF1: /* if */ 3678 case OP_IF1: /* if */
3667 if (is_true (SCHEME_V->value)) 3679 if (is_true (SCHEME_V->value))
3668 SCHEME_V->code = car (SCHEME_V->code); 3680 SCHEME_V->code = car (SCHEME_V->code);
3669 else 3681 else
3670 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because 3682 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3671
3672 * car(NIL) = NIL */
3673 s_goto (OP_EVAL); 3683 s_goto (OP_EVAL);
3674 3684
3675 case OP_LET0: /* let */ 3685 case OP_LET0: /* let */
3676 SCHEME_V->args = NIL; 3686 SCHEME_V->args = NIL;
3677 SCHEME_V->value = SCHEME_V->code; 3687 SCHEME_V->value = SCHEME_V->code;
3678 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); 3688 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3679 s_goto (OP_LET1); 3689 s_goto (OP_LET1);
3680 3690
3681 case OP_LET1: /* let (calculate parameters) */ 3691 case OP_LET1: /* let (calculate parameters) */
3682 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3692 args = cons (SCHEME_V->value, args);
3683 3693
3684 if (is_pair (SCHEME_V->code)) /* continue */ 3694 if (is_pair (SCHEME_V->code)) /* continue */
3685 { 3695 {
3686 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 3696 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3687 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); 3697 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code));
3688 3698
3689 s_save (SCHEME_A_ OP_LET1, SCHEME_V->args, cdr (SCHEME_V->code)); 3699 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code));
3690 SCHEME_V->code = cadar (SCHEME_V->code); 3700 SCHEME_V->code = cadar (SCHEME_V->code);
3691 SCHEME_V->args = NIL; 3701 SCHEME_V->args = NIL;
3692 s_goto (OP_EVAL); 3702 s_goto (OP_EVAL);
3693 } 3703 }
3694 else /* end */ 3704 else /* end */
3695 { 3705 {
3696 SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); 3706 args = reverse_in_place (SCHEME_A_ NIL, args);
3697 SCHEME_V->code = car (SCHEME_V->args); 3707 SCHEME_V->code = car (args);
3698 SCHEME_V->args = cdr (SCHEME_V->args); 3708 SCHEME_V->args = cdr (args);
3699 s_goto (OP_LET2); 3709 s_goto (OP_LET2);
3700 } 3710 }
3701 3711
3702 case OP_LET2: /* let */ 3712 case OP_LET2: /* let */
3703 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 3713 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3704 3714
3705 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = SCHEME_V->args; 3715 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
3706 y != NIL; x = cdr (x), y = cdr (y)) 3716 y != NIL; x = cdr (x), y = cdr (y))
3707 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3717 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3708 3718
3709 if (is_symbol (car (SCHEME_V->code))) /* named let */ 3719 if (is_symbol (car (SCHEME_V->code))) /* named let */
3710 { 3720 {
3711 for (x = cadr (SCHEME_V->code), SCHEME_V->args = NIL; x != NIL; x = cdr (x)) 3721 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3712 { 3722 {
3713 if (!is_pair (x)) 3723 if (!is_pair (x))
3714 Error_1 ("Bad syntax of binding in let :", x); 3724 Error_1 ("Bad syntax of binding in let :", x);
3715 3725
3716 if (!is_list (SCHEME_A_ car (x))) 3726 if (!is_list (SCHEME_A_ car (x)))
3717 Error_1 ("Bad syntax of binding in let :", car (x)); 3727 Error_1 ("Bad syntax of binding in let :", car (x));
3718 3728
3719 SCHEME_V->args = cons (caar (x), SCHEME_V->args); 3729 args = cons (caar (x), args);
3720 } 3730 }
3721 3731
3722 x =
3723 mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args), cddr (SCHEME_V->code)), 3732 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
3724 SCHEME_V->envir); 3733 SCHEME_V->envir);
3725 new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x); 3734 new_slot_in_env (SCHEME_A_ car (SCHEME_V->code), x);
3726 SCHEME_V->code = cddr (SCHEME_V->code); 3735 SCHEME_V->code = cddr (SCHEME_V->code);
3727 SCHEME_V->args = NIL;
3728 } 3736 }
3729 else 3737 else
3730 { 3738 {
3731 SCHEME_V->code = cdr (SCHEME_V->code); 3739 SCHEME_V->code = cdr (SCHEME_V->code);
3740 }
3741
3732 SCHEME_V->args = NIL; 3742 SCHEME_V->args = NIL;
3733 }
3734
3735 s_goto (OP_BEGIN); 3743 s_goto (OP_BEGIN);
3736 3744
3737 case OP_LET0AST: /* let* */ 3745 case OP_LET0AST: /* let* */
3738 if (car (SCHEME_V->code) == NIL) 3746 if (car (SCHEME_V->code) == NIL)
3739 { 3747 {
… …
3757 new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value); 3765 new_slot_in_env (SCHEME_A_ caar (SCHEME_V->code), SCHEME_V->value);
3758 SCHEME_V->code = cdr (SCHEME_V->code); 3766 SCHEME_V->code = cdr (SCHEME_V->code);
3759 3767
3760 if (is_pair (SCHEME_V->code)) /* continue */ 3768 if (is_pair (SCHEME_V->code)) /* continue */
3761 { 3769 {
3762 s_save (SCHEME_A_ OP_LET2AST, SCHEME_V->args, SCHEME_V->code); 3770 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3763 SCHEME_V->code = cadar (SCHEME_V->code); 3771 SCHEME_V->code = cadar (SCHEME_V->code);
3764 SCHEME_V->args = NIL; 3772 SCHEME_V->args = NIL;
3765 s_goto (OP_EVAL); 3773 s_goto (OP_EVAL);
3766 } 3774 }
3767 else /* end */ 3775 else /* end */
3768 { 3776 {
3769 SCHEME_V->code = SCHEME_V->args; 3777 SCHEME_V->code = args;
3770 SCHEME_V->args = NIL; 3778 SCHEME_V->args = NIL;
3771 s_goto (OP_BEGIN); 3779 s_goto (OP_BEGIN);
3772 } 3780 }
3773 3781
3774 case OP_LET0REC: /* letrec */ 3782 case OP_LET0REC: /* letrec */
… …
3777 SCHEME_V->value = SCHEME_V->code; 3785 SCHEME_V->value = SCHEME_V->code;
3778 SCHEME_V->code = car (SCHEME_V->code); 3786 SCHEME_V->code = car (SCHEME_V->code);
3779 s_goto (OP_LET1REC); 3787 s_goto (OP_LET1REC);
3780 3788
3781 case OP_LET1REC: /* letrec (calculate parameters) */ 3789 case OP_LET1REC: /* letrec (calculate parameters) */
3782 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 3790 args = cons (SCHEME_V->value, args);
3783 3791
3784 if (is_pair (SCHEME_V->code)) /* continue */ 3792 if (is_pair (SCHEME_V->code)) /* continue */
3785 { 3793 {
3786 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 3794 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3787 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code)); 3795 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3788 3796
3789 s_save (SCHEME_A_ OP_LET1REC, SCHEME_V->args, cdr (SCHEME_V->code)); 3797 s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3790 SCHEME_V->code = cadar (SCHEME_V->code); 3798 SCHEME_V->code = cadar (SCHEME_V->code);
3791 SCHEME_V->args = NIL; 3799 SCHEME_V->args = NIL;
3792 s_goto (OP_EVAL); 3800 s_goto (OP_EVAL);
3793 } 3801 }
3794 else /* end */ 3802 else /* end */
3795 { 3803 {
3796 SCHEME_V->args = reverse_in_place (SCHEME_A_ NIL, SCHEME_V->args); 3804 args = reverse_in_place (SCHEME_A_ NIL, args);
3797 SCHEME_V->code = car (SCHEME_V->args); 3805 SCHEME_V->code = car (args);
3798 SCHEME_V->args = cdr (SCHEME_V->args); 3806 SCHEME_V->args = cdr (args);
3799 s_goto (OP_LET2REC); 3807 s_goto (OP_LET2REC);
3800 } 3808 }
3801 3809
3802 case OP_LET2REC: /* letrec */ 3810 case OP_LET2REC: /* letrec */
3803 for (x = car (SCHEME_V->code), y = SCHEME_V->args; y != NIL; x = cdr (x), y = cdr (y)) 3811 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3804 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 3812 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3805 3813
3806 SCHEME_V->code = cdr (SCHEME_V->code); 3814 SCHEME_V->code = cdr (SCHEME_V->code);
3807 SCHEME_V->args = NIL; 3815 SCHEME_V->args = NIL;
3808 s_goto (OP_BEGIN); 3816 s_goto (OP_BEGIN);
… …
3894 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 3902 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3895 SCHEME_V->code = car (SCHEME_V->code); 3903 SCHEME_V->code = car (SCHEME_V->code);
3896 s_goto (OP_EVAL); 3904 s_goto (OP_EVAL);
3897 3905
3898 case OP_C1STREAM: /* cons-stream */ 3906 case OP_C1STREAM: /* cons-stream */
3899 SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register SCHEME_V->args for gc */ 3907 SCHEME_V->args = SCHEME_V->value; /* save SCHEME_V->value to register args for gc */
3900 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 3908 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3901 set_typeflag (x, T_PROMISE); 3909 set_typeflag (x, T_PROMISE);
3902 s_return (cons (SCHEME_V->args, x)); 3910 s_return (cons (args, x));
3903 3911
3904 case OP_MACRO0: /* macro */ 3912 case OP_MACRO0: /* macro */
3905 if (is_pair (car (SCHEME_V->code))) 3913 if (is_pair (car (SCHEME_V->code)))
3906 { 3914 {
3907 x = caar (SCHEME_V->code); 3915 x = caar (SCHEME_V->code);
… …
3940 { 3948 {
3941 if (!is_pair (y = caar (x))) 3949 if (!is_pair (y = caar (x)))
3942 break; 3950 break;
3943 3951
3944 for (; y != NIL; y = cdr (y)) 3952 for (; y != NIL; y = cdr (y))
3945 {
3946 if (eqv (car (y), SCHEME_V->value)) 3953 if (eqv (car (y), SCHEME_V->value))
3947 break; 3954 break;
3948 }
3949 3955
3950 if (y != NIL) 3956 if (y != NIL)
3951 break; 3957 break;
3952 } 3958 }
3953 3959
… …
3973 s_goto (OP_BEGIN); 3979 s_goto (OP_BEGIN);
3974 else 3980 else
3975 s_return (NIL); 3981 s_return (NIL);
3976 3982
3977 case OP_PAPPLY: /* apply */ 3983 case OP_PAPPLY: /* apply */
3978 SCHEME_V->code = car (SCHEME_V->args); 3984 SCHEME_V->code = car (args);
3979 SCHEME_V->args = list_star (SCHEME_A_ cdr (SCHEME_V->args)); 3985 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3980 /*SCHEME_V->args = cadr(SCHEME_V->args); */ 3986 /*SCHEME_V->args = cadr(args); */
3981 s_goto (OP_APPLY); 3987 s_goto (OP_APPLY);
3982 3988
3983 case OP_PEVAL: /* eval */ 3989 case OP_PEVAL: /* eval */
3984 if (cdr (SCHEME_V->args) != NIL) 3990 if (cdr (args) != NIL)
3985 SCHEME_V->envir = cadr (SCHEME_V->args); 3991 SCHEME_V->envir = cadr (args);
3986 3992
3987 SCHEME_V->code = car (SCHEME_V->args); 3993 SCHEME_V->code = car (args);
3988 s_goto (OP_EVAL); 3994 s_goto (OP_EVAL);
3989 3995
3990 case OP_CONTINUATION: /* call-with-current-continuation */ 3996 case OP_CONTINUATION: /* call-with-current-continuation */
3991 SCHEME_V->code = car (SCHEME_V->args); 3997 SCHEME_V->code = car (args);
3992 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_V)), NIL); 3998 SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL);
3993 s_goto (OP_APPLY); 3999 s_goto (OP_APPLY);
3994 } 4000 }
3995 4001
3996 return S_T; 4002 if (USE_ERROR_CHECKING) abort ();
3997} 4003}
3998 4004
3999static pointer 4005/* math, cxr */
4006ecb_hot static int
4000opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4007opexe_1 (SCHEME_P_ enum scheme_opcodes op)
4001{ 4008{
4002 pointer x; 4009 pointer args = SCHEME_V->args;
4010 pointer x = car (args);
4003 num v; 4011 num v;
4004 4012
4013 switch (op)
4014 {
4005#if USE_MATH 4015#if USE_MATH
4006 RVALUE dd;
4007#endif
4008
4009 switch (op)
4010 {
4011#if USE_MATH
4012
4013 case OP_INEX2EX: /* inexact->exact */ 4016 case OP_INEX2EX: /* inexact->exact */
4014 x = car (SCHEME_V->args);
4015
4016 if (num_is_integer (x)) 4017 if (!is_integer (x))
4017 s_return (x); 4018 {
4018 else if (modf (rvalue_unchecked (x), &dd) == 0.0) 4019 RVALUE r = rvalue_unchecked (x);
4019 s_return (mk_integer (SCHEME_A_ ivalue (x))); 4020
4021 if (r == (RVALUE)(IVALUE)r)
4022 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4020 else 4023 else
4021 Error_1 ("inexact->exact: not integral:", x); 4024 Error_1 ("inexact->exact: not integral:", x);
4025 }
4022 4026
4023 case OP_EXP: 4027 s_return (x);
4024 x = car (SCHEME_V->args); 4028
4029 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4030 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4031 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4032 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4033
4034 case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4025 s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4035 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4026
4027 case OP_LOG:
4028 x = car (SCHEME_V->args);
4029 s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4036 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4030 4037 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4031 case OP_SIN:
4032 x = car (SCHEME_V->args);
4033 s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4038 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4034
4035 case OP_COS:
4036 x = car (SCHEME_V->args);
4037 s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4039 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4038
4039 case OP_TAN:
4040 x = car (SCHEME_V->args);
4041 s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4040 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4042
4043 case OP_ASIN:
4044 x = car (SCHEME_V->args);
4045 s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4041 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4046
4047 case OP_ACOS:
4048 x = car (SCHEME_V->args);
4049 s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4042 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4050 4043
4051 case OP_ATAN: 4044 case OP_ATAN:
4052 x = car (SCHEME_V->args);
4053
4054 if (cdr (SCHEME_V->args) == NIL)
4055 s_return (mk_real (SCHEME_A_ atan (rvalue (x))));
4056 else
4057 {
4058 pointer y = cadr (SCHEME_V->args);
4059
4060 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4061 }
4062
4063 case OP_SQRT:
4064 x = car (SCHEME_V->args);
4065 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x)))); 4045 s_return (mk_real (SCHEME_A_
4046 cdr (args) == NIL
4047 ? atan (rvalue (x))
4048 : atan2 (rvalue (x), rvalue (cadr (args)))));
4066 4049
4067 case OP_EXPT: 4050 case OP_EXPT:
4068 { 4051 {
4069 RVALUE result; 4052 RVALUE result;
4070 int real_result = 1; 4053 int real_result = 1;
4071 pointer y = cadr (SCHEME_V->args); 4054 pointer y = cadr (args);
4072 4055
4073 x = car (SCHEME_V->args);
4074
4075 if (num_is_integer (x) && num_is_integer (y)) 4056 if (is_integer (x) && is_integer (y))
4076 real_result = 0; 4057 real_result = 0;
4077 4058
4078 /* This 'if' is an R5RS compatibility fix. */ 4059 /* This 'if' is an R5RS compatibility fix. */
4079 /* NOTE: Remove this 'if' fix for R6RS. */ 4060 /* NOTE: Remove this 'if' fix for R6RS. */
4080 if (rvalue (x) == 0 && rvalue (y) < 0) 4061 if (rvalue (x) == 0 && rvalue (y) < 0)
4081 result = 0.0; 4062 result = 0;
4082 else 4063 else
4083 result = pow (rvalue (x), rvalue (y)); 4064 result = pow (rvalue (x), rvalue (y));
4084 4065
4085 /* Before returning integer result make sure we can. */ 4066 /* Before returning integer result make sure we can. */
4086 /* If the test fails, result is too big for integer. */ 4067 /* If the test fails, result is too big for integer. */
4087 if (!real_result) 4068 if (!real_result)
4088 { 4069 {
4089 long result_as_long = (long) result; 4070 long result_as_long = result;
4090 4071
4091 if (result != (RVALUE) result_as_long) 4072 if (result != result_as_long)
4092 real_result = 1; 4073 real_result = 1;
4093 } 4074 }
4094 4075
4095 if (real_result) 4076 if (real_result)
4096 s_return (mk_real (SCHEME_A_ result)); 4077 s_return (mk_real (SCHEME_A_ result));
4097 else 4078 else
4098 s_return (mk_integer (SCHEME_A_ result)); 4079 s_return (mk_integer (SCHEME_A_ result));
4099 } 4080 }
4100
4101 case OP_FLOOR:
4102 x = car (SCHEME_V->args);
4103 s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4104
4105 case OP_CEILING:
4106 x = car (SCHEME_V->args);
4107 s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4108
4109 case OP_TRUNCATE:
4110 {
4111 RVALUE rvalue_of_x;
4112
4113 x = car (SCHEME_V->args);
4114 rvalue_of_x = rvalue (x);
4115
4116 if (rvalue_of_x > 0)
4117 s_return (mk_real (SCHEME_A_ floor (rvalue_of_x)));
4118 else
4119 s_return (mk_real (SCHEME_A_ ceil (rvalue_of_x)));
4120 }
4121
4122 case OP_ROUND:
4123 x = car (SCHEME_V->args);
4124
4125 if (num_is_integer (x))
4126 s_return (x);
4127
4128 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4129#endif 4081#endif
4130 4082
4131 case OP_ADD: /* + */ 4083 case OP_ADD: /* + */
4132 v = num_zero; 4084 v = num_zero;
4133 4085
4134 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4086 for (x = args; x != NIL; x = cdr (x))
4135 v = num_add (v, nvalue (car (x))); 4087 v = num_op (NUM_ADD, v, nvalue (car (x)));
4136 4088
4137 s_return (mk_number (SCHEME_A_ v)); 4089 s_return (mk_number (SCHEME_A_ v));
4138 4090
4139 case OP_MUL: /* * */ 4091 case OP_MUL: /* * */
4140 v = num_one; 4092 v = num_one;
4141 4093
4142 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4094 for (x = args; x != NIL; x = cdr (x))
4143 v = num_mul (v, nvalue (car (x))); 4095 v = num_op (NUM_MUL, v, nvalue (car (x)));
4144 4096
4145 s_return (mk_number (SCHEME_A_ v)); 4097 s_return (mk_number (SCHEME_A_ v));
4146 4098
4147 case OP_SUB: /* - */ 4099 case OP_SUB: /* - */
4148 if (cdr (SCHEME_V->args) == NIL) 4100 if (cdr (args) == NIL)
4149 { 4101 {
4150 x = SCHEME_V->args; 4102 x = args;
4151 v = num_zero; 4103 v = num_zero;
4152 } 4104 }
4153 else 4105 else
4154 { 4106 {
4155 x = cdr (SCHEME_V->args); 4107 x = cdr (args);
4156 v = nvalue (car (SCHEME_V->args)); 4108 v = nvalue (car (args));
4157 } 4109 }
4158 4110
4159 for (; x != NIL; x = cdr (x)) 4111 for (; x != NIL; x = cdr (x))
4160 v = num_sub (v, nvalue (car (x))); 4112 v = num_op (NUM_SUB, v, nvalue (car (x)));
4161 4113
4162 s_return (mk_number (SCHEME_A_ v)); 4114 s_return (mk_number (SCHEME_A_ v));
4163 4115
4164 case OP_DIV: /* / */ 4116 case OP_DIV: /* / */
4165 if (cdr (SCHEME_V->args) == NIL) 4117 if (cdr (args) == NIL)
4166 { 4118 {
4167 x = SCHEME_V->args; 4119 x = args;
4168 v = num_one; 4120 v = num_one;
4169 } 4121 }
4170 else 4122 else
4171 { 4123 {
4172 x = cdr (SCHEME_V->args); 4124 x = cdr (args);
4173 v = nvalue (car (SCHEME_V->args)); 4125 v = nvalue (car (args));
4174 } 4126 }
4175 4127
4176 for (; x != NIL; x = cdr (x)) 4128 for (; x != NIL; x = cdr (x))
4177 {
4178 if (!is_zero_rvalue (rvalue (car (x)))) 4129 if (!is_zero_rvalue (rvalue (car (x))))
4179 v = num_div (v, nvalue (car (x))); 4130 v = num_div (v, nvalue (car (x)));
4180 else 4131 else
4181 Error_0 ("/: division by zero"); 4132 Error_0 ("/: division by zero");
4182 }
4183 4133
4184 s_return (mk_number (SCHEME_A_ v)); 4134 s_return (mk_number (SCHEME_A_ v));
4185 4135
4186 case OP_INTDIV: /* quotient */ 4136 case OP_INTDIV: /* quotient */
4187 if (cdr (SCHEME_V->args) == NIL) 4137 if (cdr (args) == NIL)
4188 { 4138 {
4189 x = SCHEME_V->args; 4139 x = args;
4190 v = num_one; 4140 v = num_one;
4191 } 4141 }
4192 else 4142 else
4193 { 4143 {
4194 x = cdr (SCHEME_V->args); 4144 x = cdr (args);
4195 v = nvalue (car (SCHEME_V->args)); 4145 v = nvalue (car (args));
4196 } 4146 }
4197 4147
4198 for (; x != NIL; x = cdr (x)) 4148 for (; x != NIL; x = cdr (x))
4199 { 4149 {
4200 if (ivalue (car (x)) != 0) 4150 if (ivalue (car (x)) != 0)
4201 v = num_intdiv (v, nvalue (car (x))); 4151 v = num_op (NUM_INTDIV, v, nvalue (car (x)));
4202 else 4152 else
4203 Error_0 ("quotient: division by zero"); 4153 Error_0 ("quotient: division by zero");
4204 } 4154 }
4205 4155
4206 s_return (mk_number (SCHEME_A_ v)); 4156 s_return (mk_number (SCHEME_A_ v));
4207 4157
4208 case OP_REM: /* remainder */ 4158 case OP_REM: /* remainder */
4209 v = nvalue (car (SCHEME_V->args)); 4159 v = nvalue (x);
4210 4160
4211 if (ivalue (cadr (SCHEME_V->args)) != 0) 4161 if (ivalue (cadr (args)) != 0)
4212 v = num_rem (v, nvalue (cadr (SCHEME_V->args))); 4162 v = num_rem (v, nvalue (cadr (args)));
4213 else 4163 else
4214 Error_0 ("remainder: division by zero"); 4164 Error_0 ("remainder: division by zero");
4215 4165
4216 s_return (mk_number (SCHEME_A_ v)); 4166 s_return (mk_number (SCHEME_A_ v));
4217 4167
4218 case OP_MOD: /* modulo */ 4168 case OP_MOD: /* modulo */
4219 v = nvalue (car (SCHEME_V->args)); 4169 v = nvalue (x);
4220 4170
4221 if (ivalue (cadr (SCHEME_V->args)) != 0) 4171 if (ivalue (cadr (args)) != 0)
4222 v = num_mod (v, nvalue (cadr (SCHEME_V->args))); 4172 v = num_mod (v, nvalue (cadr (args)));
4223 else 4173 else
4224 Error_0 ("modulo: division by zero"); 4174 Error_0 ("modulo: division by zero");
4225 4175
4226 s_return (mk_number (SCHEME_A_ v)); 4176 s_return (mk_number (SCHEME_A_ v));
4227 4177
4228 case OP_CAR: /* car */ 4178 /* the compiler will optimize this mess... */
4229 s_return (caar (SCHEME_V->args)); 4179 case OP_CAR: op_car: s_return (car (x));
4230 4180 case OP_CDR: op_cdr: s_return (cdr (x));
4231 case OP_CDR: /* cdr */ 4181 case OP_CAAR: op_caar: x = car (x); goto op_car;
4232 s_return (cdar (SCHEME_V->args)); 4182 case OP_CADR: op_cadr: x = cdr (x); goto op_car;
4183 case OP_CDAR: op_cdar: x = car (x); goto op_cdr;
4184 case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr;
4185 case OP_CAAAR: op_caaar: x = car (x); goto op_caar;
4186 case OP_CAADR: op_caadr: x = cdr (x); goto op_caar;
4187 case OP_CADAR: op_cadar: x = car (x); goto op_cadr;
4188 case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr;
4189 case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar;
4190 case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar;
4191 case OP_CDDAR: op_cddar: x = car (x); goto op_cddr;
4192 case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr;
4193 case OP_CAAAAR: x = car (x); goto op_caaar;
4194 case OP_CAAADR: x = cdr (x); goto op_caaar;
4195 case OP_CAADAR: x = car (x); goto op_caadr;
4196 case OP_CAADDR: x = cdr (x); goto op_caadr;
4197 case OP_CADAAR: x = car (x); goto op_cadar;
4198 case OP_CADADR: x = cdr (x); goto op_cadar;
4199 case OP_CADDAR: x = car (x); goto op_caddr;
4200 case OP_CADDDR: x = cdr (x); goto op_caddr;
4201 case OP_CDAAAR: x = car (x); goto op_cdaar;
4202 case OP_CDAADR: x = cdr (x); goto op_cdaar;
4203 case OP_CDADAR: x = car (x); goto op_cdadr;
4204 case OP_CDADDR: x = cdr (x); goto op_cdadr;
4205 case OP_CDDAAR: x = car (x); goto op_cddar;
4206 case OP_CDDADR: x = cdr (x); goto op_cddar;
4207 case OP_CDDDAR: x = car (x); goto op_cdddr;
4208 case OP_CDDDDR: x = cdr (x); goto op_cdddr;
4233 4209
4234 case OP_CONS: /* cons */ 4210 case OP_CONS: /* cons */
4235 set_cdr (SCHEME_V->args, cadr (SCHEME_V->args)); 4211 set_cdr (args, cadr (args));
4236 s_return (SCHEME_V->args); 4212 s_return (args);
4237 4213
4238 case OP_SETCAR: /* set-car! */ 4214 case OP_SETCAR: /* set-car! */
4239 if (!is_immutable (car (SCHEME_V->args))) 4215 if (!is_immutable (x))
4240 { 4216 {
4241 set_car (car (SCHEME_V->args), cadr (SCHEME_V->args)); 4217 set_car (x, cadr (args));
4242 s_return (car (SCHEME_V->args)); 4218 s_return (car (args));
4243 } 4219 }
4244 else 4220 else
4245 Error_0 ("set-car!: unable to alter immutable pair"); 4221 Error_0 ("set-car!: unable to alter immutable pair");
4246 4222
4247 case OP_SETCDR: /* set-cdr! */ 4223 case OP_SETCDR: /* set-cdr! */
4248 if (!is_immutable (car (SCHEME_V->args))) 4224 if (!is_immutable (x))
4249 { 4225 {
4250 set_cdr (car (SCHEME_V->args), cadr (SCHEME_V->args)); 4226 set_cdr (x, cadr (args));
4251 s_return (car (SCHEME_V->args)); 4227 s_return (car (args));
4252 } 4228 }
4253 else 4229 else
4254 Error_0 ("set-cdr!: unable to alter immutable pair"); 4230 Error_0 ("set-cdr!: unable to alter immutable pair");
4255 4231
4256 case OP_CHAR2INT: /* char->integer */ 4232 case OP_CHAR2INT: /* char->integer */
4257 s_return (mk_integer (SCHEME_A_ ivalue (car (SCHEME_V->args)))); 4233 s_return (mk_integer (SCHEME_A_ ivalue_unchecked (x)));
4258 4234
4259 case OP_INT2CHAR: /* integer->char */ 4235 case OP_INT2CHAR: /* integer->char */
4260 s_return (mk_character (SCHEME_A_ ivalue (car (SCHEME_V->args)))); 4236 s_return (mk_character (SCHEME_A_ ivalue_unchecked (x)));
4261 4237
4262 case OP_CHARUPCASE: 4238 case OP_CHARUPCASE:
4263 { 4239 {
4264 unsigned char c = ivalue (car (SCHEME_V->args)); 4240 unsigned char c = ivalue_unchecked (x);
4265 c = toupper (c); 4241 c = toupper (c);
4266 s_return (mk_character (SCHEME_A_ c)); 4242 s_return (mk_character (SCHEME_A_ c));
4267 } 4243 }
4268 4244
4269 case OP_CHARDNCASE: 4245 case OP_CHARDNCASE:
4270 { 4246 {
4271 unsigned char c = ivalue (car (SCHEME_V->args)); 4247 unsigned char c = ivalue_unchecked (x);
4272 c = tolower (c); 4248 c = tolower (c);
4273 s_return (mk_character (SCHEME_A_ c)); 4249 s_return (mk_character (SCHEME_A_ c));
4274 } 4250 }
4275 4251
4276 case OP_STR2SYM: /* string->symbol */ 4252 case OP_STR2SYM: /* string->symbol */
4277 s_return (mk_symbol (SCHEME_A_ strvalue (car (SCHEME_V->args)))); 4253 s_return (mk_symbol (SCHEME_A_ strvalue (x)));
4278 4254
4279 case OP_STR2ATOM: /* string->atom */ 4255 case OP_STR2ATOM: /* string->atom */
4280 { 4256 {
4281 char *s = strvalue (car (SCHEME_V->args)); 4257 char *s = strvalue (x);
4282 long pf = 0; 4258 long pf = 0;
4283 4259
4284 if (cdr (SCHEME_V->args) != NIL) 4260 if (cdr (args) != NIL)
4285 { 4261 {
4286 /* we know cadr(SCHEME_V->args) is a natural number */ 4262 /* we know cadr(args) is a natural number */
4287 /* see if it is 2, 8, 10, or 16, or error */ 4263 /* see if it is 2, 8, 10, or 16, or error */
4288 pf = ivalue_unchecked (cadr (SCHEME_V->args)); 4264 pf = ivalue_unchecked (cadr (args));
4289 4265
4290 if (pf == 16 || pf == 10 || pf == 8 || pf == 2) 4266 if (pf == 16 || pf == 10 || pf == 8 || pf == 2)
4291 { 4267 {
4292 /* base is OK */ 4268 /* base is OK */
4293 } 4269 }
4294 else 4270 else
4295 pf = -1; 4271 pf = -1;
4296 } 4272 }
4297 4273
4298 if (pf < 0) 4274 if (pf < 0)
4299 Error_1 ("string->atom: bad base:", cadr (SCHEME_V->args)); 4275 Error_1 ("string->atom: bad base:", cadr (args));
4300 else if (*s == '#') /* no use of base! */ 4276 else if (*s == '#') /* no use of base! */
4301 s_return (mk_sharp_const (SCHEME_A_ s + 1)); 4277 s_return (mk_sharp_const (SCHEME_A_ s + 1));
4302 else 4278 else
4303 { 4279 {
4304 if (pf == 0 || pf == 10) 4280 if (pf == 0 || pf == 10)
… …
4315 } 4291 }
4316 } 4292 }
4317 } 4293 }
4318 4294
4319 case OP_SYM2STR: /* symbol->string */ 4295 case OP_SYM2STR: /* symbol->string */
4320 x = mk_string (SCHEME_A_ symname (car (SCHEME_V->args))); 4296 x = mk_string (SCHEME_A_ symname (x));
4321 setimmutable (x); 4297 setimmutable (x);
4322 s_return (x); 4298 s_return (x);
4323 4299
4324 case OP_ATOM2STR: /* atom->string */ 4300 case OP_ATOM2STR: /* atom->string */
4325 { 4301 {
4326 long pf = 0; 4302 long pf = 0;
4327 4303
4328 x = car (SCHEME_V->args);
4329
4330 if (cdr (SCHEME_V->args) != NIL) 4304 if (cdr (args) != NIL)
4331 { 4305 {
4332 /* we know cadr(SCHEME_V->args) is a natural number */ 4306 /* we know cadr(args) is a natural number */
4333 /* see if it is 2, 8, 10, or 16, or error */ 4307 /* see if it is 2, 8, 10, or 16, or error */
4334 pf = ivalue_unchecked (cadr (SCHEME_V->args)); 4308 pf = ivalue_unchecked (cadr (args));
4335 4309
4336 if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) 4310 if (is_number (x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2))
4337 { 4311 {
4338 /* base is OK */ 4312 /* base is OK */
4339 } 4313 }
4340 else 4314 else
4341 pf = -1; 4315 pf = -1;
4342 } 4316 }
4343 4317
4344 if (pf < 0) 4318 if (pf < 0)
4345 Error_1 ("atom->string: bad base:", cadr (SCHEME_V->args)); 4319 Error_1 ("atom->string: bad base:", cadr (args));
4346 else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x)) 4320 else if (is_number (x) || is_character (x) || is_string (x) || is_symbol (x))
4347 { 4321 {
4348 char *p; 4322 char *p;
4349 int len; 4323 int len;
4350 4324
… …
4355 Error_1 ("atom->string: not an atom:", x); 4329 Error_1 ("atom->string: not an atom:", x);
4356 } 4330 }
4357 4331
4358 case OP_MKSTRING: /* make-string */ 4332 case OP_MKSTRING: /* make-string */
4359 { 4333 {
4360 int fill = ' '; 4334 int fill = cdr (args) != NIL ? charvalue (cadr (args)) : ' ';
4361 int len; 4335 int len = ivalue_unchecked (x);
4362 4336
4363 len = ivalue (car (SCHEME_V->args));
4364
4365 if (cdr (SCHEME_V->args) != NIL)
4366 fill = charvalue (cadr (SCHEME_V->args));
4367
4368 s_return (mk_empty_string (SCHEME_A_ len, (char) fill)); 4337 s_return (mk_empty_string (SCHEME_A_ len, fill));
4369 } 4338 }
4370 4339
4371 case OP_STRLEN: /* string-length */ 4340 case OP_STRLEN: /* string-length */
4372 s_return (mk_integer (SCHEME_A_ strlength (car (SCHEME_V->args)))); 4341 s_return (mk_integer (SCHEME_A_ strlength (x)));
4373 4342
4374 case OP_STRREF: /* string-ref */ 4343 case OP_STRREF: /* string-ref */
4375 { 4344 {
4376 char *str; 4345 char *str = strvalue (x);
4377 int index;
4378
4379 str = strvalue (car (SCHEME_V->args));
4380
4381 index = ivalue (cadr (SCHEME_V->args)); 4346 int index = ivalue_unchecked (cadr (args));
4382 4347
4383 if (index >= strlength (car (SCHEME_V->args))) 4348 if (index >= strlength (x))
4384 Error_1 ("string-ref: out of bounds:", cadr (SCHEME_V->args)); 4349 Error_1 ("string-ref: out of bounds:", cadr (args));
4385 4350
4386 s_return (mk_character (SCHEME_A_ ((unsigned char *) str)[index])); 4351 s_return (mk_character (SCHEME_A_ ((unsigned char *)str)[index]));
4387 } 4352 }
4388 4353
4389 case OP_STRSET: /* string-set! */ 4354 case OP_STRSET: /* string-set! */
4390 { 4355 {
4391 char *str; 4356 char *str = strvalue (x);
4392 int index; 4357 int index = ivalue_unchecked (cadr (args));
4393 int c; 4358 int c;
4394 4359
4395 if (is_immutable (car (SCHEME_V->args))) 4360 if (is_immutable (x))
4396 Error_1 ("string-set!: unable to alter immutable string:", car (SCHEME_V->args)); 4361 Error_1 ("string-set!: unable to alter immutable string:", x);
4397 4362
4398 str = strvalue (car (SCHEME_V->args));
4399
4400 index = ivalue (cadr (SCHEME_V->args));
4401
4402 if (index >= strlength (car (SCHEME_V->args))) 4363 if (index >= strlength (x))
4403 Error_1 ("string-set!: out of bounds:", cadr (SCHEME_V->args)); 4364 Error_1 ("string-set!: out of bounds:", cadr (args));
4404 4365
4405 c = charvalue (caddr (SCHEME_V->args)); 4366 c = charvalue (caddr (args));
4406 4367
4407 str[index] = (char) c; 4368 str[index] = c;
4408 s_return (car (SCHEME_V->args)); 4369 s_return (car (args));
4409 } 4370 }
4410 4371
4411 case OP_STRAPPEND: /* string-append */ 4372 case OP_STRAPPEND: /* string-append */
4412 { 4373 {
4413 /* in 1.29 string-append was in Scheme in init.scm but was too slow */ 4374 /* in 1.29 string-append was in Scheme in init.scm but was too slow */
4414 int len = 0; 4375 int len = 0;
4415 pointer newstr; 4376 pointer newstr;
4416 char *pos; 4377 char *pos;
4417 4378
4418 /* compute needed length for new string */ 4379 /* compute needed length for new string */
4419 for (x = SCHEME_V->args; x != NIL; x = cdr (x)) 4380 for (x = args; x != NIL; x = cdr (x))
4420 len += strlength (car (x)); 4381 len += strlength (car (x));
4421 4382
4422 newstr = mk_empty_string (SCHEME_A_ len, ' '); 4383 newstr = mk_empty_string (SCHEME_A_ len, ' ');
4423 4384
4424 /* store the contents of the argument strings into the new string */ 4385 /* store the contents of the argument strings into the new string */
4425 for (pos = strvalue (newstr), x = SCHEME_V->args; x != NIL; pos += strlength (car (x)), x = cdr (x)) 4386 for (pos = strvalue (newstr), x = args; x != NIL; pos += strlength (car (x)), x = cdr (x))
4426 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4387 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4427 4388
4428 s_return (newstr); 4389 s_return (newstr);
4429 } 4390 }
4430 4391
4431 case OP_SUBSTR: /* substring */ 4392 case OP_STRING_COPY: /* substring/string-copy */
4432 { 4393 {
4433 char *str; 4394 char *str = strvalue (x);
4434 int index0; 4395 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4435 int index1; 4396 int index1;
4436 int len; 4397 int len;
4437 4398
4438 str = strvalue (car (SCHEME_V->args));
4439
4440 index0 = ivalue (cadr (SCHEME_V->args));
4441
4442 if (index0 > strlength (car (SCHEME_V->args))) 4399 if (index0 > strlength (x))
4443 Error_1 ("substring: start out of bounds:", cadr (SCHEME_V->args)); 4400 Error_1 ("string->copy: start out of bounds:", cadr (args));
4444 4401
4445 if (cddr (SCHEME_V->args) != NIL) 4402 if (cddr (args) != NIL)
4446 { 4403 {
4447 index1 = ivalue (caddr (SCHEME_V->args)); 4404 index1 = ivalue_unchecked (caddr (args));
4448 4405
4449 if (index1 > strlength (car (SCHEME_V->args)) || index1 < index0) 4406 if (index1 > strlength (x) || index1 < index0)
4450 Error_1 ("substring: end out of bounds:", caddr (SCHEME_V->args)); 4407 Error_1 ("string->copy: end out of bounds:", caddr (args));
4451 } 4408 }
4452 else 4409 else
4453 index1 = strlength (car (SCHEME_V->args)); 4410 index1 = strlength (x);
4454 4411
4455 len = index1 - index0; 4412 len = index1 - index0;
4456 x = mk_empty_string (SCHEME_A_ len, ' '); 4413 x = mk_counted_string (SCHEME_A_ str + index0, len);
4457 memcpy (strvalue (x), str + index0, len);
4458 strvalue (x)[len] = 0;
4459 4414
4460 s_return (x); 4415 s_return (x);
4461 } 4416 }
4462 4417
4463 case OP_VECTOR: /* vector */ 4418 case OP_VECTOR: /* vector */
4464 { 4419 {
4465 int i; 4420 int i;
4466 pointer vec; 4421 pointer vec;
4467 int len = list_length (SCHEME_A_ SCHEME_V->args); 4422 int len = list_length (SCHEME_A_ args);
4468 4423
4469 if (len < 0) 4424 if (len < 0)
4470 Error_1 ("vector: not a proper list:", SCHEME_V->args); 4425 Error_1 ("vector: not a proper list:", args);
4471 4426
4472 vec = mk_vector (SCHEME_A_ len); 4427 vec = mk_vector (SCHEME_A_ len);
4473 4428
4474#if USE_ERROR_CHECKING 4429#if USE_ERROR_CHECKING
4475 if (SCHEME_V->no_memory) 4430 if (SCHEME_V->no_memory)
4476 s_return (S_SINK); 4431 s_return (S_SINK);
4477#endif 4432#endif
4478 4433
4479 for (x = SCHEME_V->args, i = 0; is_pair (x); x = cdr (x), i++) 4434 for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
4480 set_vector_elem (vec, i, car (x)); 4435 vector_set (vec, i, car (x));
4481 4436
4482 s_return (vec); 4437 s_return (vec);
4483 } 4438 }
4484 4439
4485 case OP_MKVECTOR: /* make-vector */ 4440 case OP_MKVECTOR: /* make-vector */
4486 { 4441 {
4487 pointer fill = NIL; 4442 pointer fill = NIL;
4488 int len;
4489 pointer vec; 4443 pointer vec;
4444 int len = ivalue_unchecked (x);
4490 4445
4491 len = ivalue (car (SCHEME_V->args));
4492
4493 if (cdr (SCHEME_V->args) != NIL) 4446 if (cdr (args) != NIL)
4494 fill = cadr (SCHEME_V->args); 4447 fill = cadr (args);
4495 4448
4496 vec = mk_vector (SCHEME_A_ len); 4449 vec = mk_vector (SCHEME_A_ len);
4497 4450
4498#if USE_ERROR_CHECKING 4451#if USE_ERROR_CHECKING
4499 if (SCHEME_V->no_memory) 4452 if (SCHEME_V->no_memory)
4500 s_return (S_SINK); 4453 s_return (S_SINK);
4501#endif 4454#endif
4502 4455
4503 if (fill != NIL) 4456 if (fill != NIL)
4504 fill_vector (vec, fill); 4457 fill_vector (vec, 0, fill);
4505 4458
4506 s_return (vec); 4459 s_return (vec);
4507 } 4460 }
4508 4461
4509 case OP_VECLEN: /* vector-length */ 4462 case OP_VECLEN: /* vector-length */
4510 s_return (mk_integer (SCHEME_A_ vector_length (car (SCHEME_V->args)))); 4463 s_return (mk_integer (SCHEME_A_ veclength (x)));
4464
4465 case OP_VECRESIZE:
4466 vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
4467 s_return (x);
4511 4468
4512 case OP_VECREF: /* vector-ref */ 4469 case OP_VECREF: /* vector-ref */
4513 { 4470 {
4514 int index;
4515
4516 index = ivalue (cadr (SCHEME_V->args)); 4471 int index = ivalue_unchecked (cadr (args));
4517 4472
4518 if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4473 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4519 Error_1 ("vector-ref: out of bounds:", cadr (SCHEME_V->args)); 4474 Error_1 ("vector-ref: out of bounds:", cadr (args));
4520 4475
4521 s_return (vector_elem (car (SCHEME_V->args), index)); 4476 s_return (vector_get (x, index));
4522 } 4477 }
4523 4478
4524 case OP_VECSET: /* vector-set! */ 4479 case OP_VECSET: /* vector-set! */
4525 { 4480 {
4526 int index; 4481 int index = ivalue_unchecked (cadr (args));
4527 4482
4528 if (is_immutable (car (SCHEME_V->args))) 4483 if (is_immutable (x))
4529 Error_1 ("vector-set!: unable to alter immutable vector:", car (SCHEME_V->args)); 4484 Error_1 ("vector-set!: unable to alter immutable vector:", x);
4530 4485
4531 index = ivalue (cadr (SCHEME_V->args));
4532
4533 if (index >= vector_length (car (SCHEME_V->args)) && USE_ERROR_CHECKING) 4486 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
4534 Error_1 ("vector-set!: out of bounds:", cadr (SCHEME_V->args)); 4487 Error_1 ("vector-set!: out of bounds:", cadr (args));
4535 4488
4536 set_vector_elem (car (SCHEME_V->args), index, caddr (SCHEME_V->args)); 4489 vector_set (x, index, caddr (args));
4537 s_return (car (SCHEME_V->args)); 4490 s_return (x);
4538 } 4491 }
4539 } 4492 }
4540 4493
4541 return S_T; 4494 if (USE_ERROR_CHECKING) abort ();
4542} 4495}
4543 4496
4544INTERFACE int 4497/* relational ops */
4545is_list (SCHEME_P_ pointer a) 4498ecb_hot static int
4499opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4546{ 4500{
4547 return list_length (SCHEME_A_ a) >= 0; 4501 pointer x = SCHEME_V->args;
4548}
4549 4502
4550/* Result is: 4503 for (;;)
4551 proper list: length
4552 circular list: -1
4553 not even a pair: -2
4554 dotted list: -2 minus length before dot
4555*/
4556INTERFACE int
4557list_length (SCHEME_P_ pointer a)
4558{
4559 int i = 0;
4560 pointer slow, fast;
4561
4562 slow = fast = a;
4563
4564 while (1)
4565 { 4504 {
4505 num v = nvalue (car (x));
4506 x = cdr (x);
4507
4566 if (fast == NIL) 4508 if (x == NIL)
4567 return i; 4509 break;
4568 4510
4569 if (!is_pair (fast)) 4511 int r = num_cmp (v, nvalue (car (x)));
4570 return -2 - i;
4571 4512
4572 fast = cdr (fast); 4513 switch (op)
4573 ++i;
4574
4575 if (fast == NIL)
4576 return i;
4577
4578 if (!is_pair (fast))
4579 return -2 - i;
4580
4581 ++i;
4582 fast = cdr (fast);
4583
4584 /* Safe because we would have already returned if `fast'
4585 encountered a non-pair. */
4586 slow = cdr (slow);
4587
4588 if (fast == slow)
4589 { 4514 {
4590 /* the fast pointer has looped back around and caught up 4515 case OP_NUMEQ: r = r == 0; break;
4591 with the slow pointer, hence the structure is circular, 4516 case OP_LESS: r = r < 0; break;
4592 not of finite length, and therefore not a list */ 4517 case OP_GRE: r = r > 0; break;
4593 return -1; 4518 case OP_LEQ: r = r <= 0; break;
4519 case OP_GEQ: r = r >= 0; break;
4594 } 4520 }
4595 }
4596}
4597 4521
4598static pointer 4522 if (!r)
4523 s_return (S_F);
4524 }
4525
4526 s_return (S_T);
4527}
4528
4529/* predicates */
4530ecb_hot static int
4599opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4531opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4600{ 4532{
4601 pointer x; 4533 pointer args = SCHEME_V->args;
4602 num v; 4534 pointer a = car (args);
4603 int (*comp_func) (num, num); 4535 pointer d = cdr (args);
4536 int r;
4604 4537
4605 switch (op) 4538 switch (op)
4606 { 4539 {
4607 case OP_NOT: /* not */ 4540 case OP_NOT: /* not */ r = is_false (a) ; break;
4608 s_retbool (is_false (car (SCHEME_V->args))); 4541 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break;
4542 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4543 case OP_NULLP: /* null? */ r = a == NIL ; break;
4544 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
4545 case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break;
4546 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4547 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4548 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4549 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4550 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4609 4551
4610 case OP_BOOLP: /* boolean? */
4611 s_retbool (car (SCHEME_V->args) == S_F || car (SCHEME_V->args) == S_T);
4612
4613 case OP_EOFOBJP: /* boolean? */
4614 s_retbool (car (SCHEME_V->args) == S_EOF);
4615
4616 case OP_NULLP: /* null? */
4617 s_retbool (car (SCHEME_V->args) == NIL);
4618
4619 case OP_NUMEQ: /* = */
4620 case OP_LESS: /* < */
4621 case OP_GRE: /* > */
4622 case OP_LEQ: /* <= */
4623 case OP_GEQ: /* >= */
4624 switch (op)
4625 {
4626 case OP_NUMEQ:
4627 comp_func = num_eq;
4628 break;
4629
4630 case OP_LESS:
4631 comp_func = num_lt;
4632 break;
4633
4634 case OP_GRE:
4635 comp_func = num_gt;
4636 break;
4637
4638 case OP_LEQ:
4639 comp_func = num_le;
4640 break;
4641
4642 case OP_GEQ:
4643 comp_func = num_ge;
4644 break;
4645 }
4646
4647 x = SCHEME_V->args;
4648 v = nvalue (car (x));
4649 x = cdr (x);
4650
4651 for (; x != NIL; x = cdr (x))
4652 {
4653 if (!comp_func (v, nvalue (car (x))))
4654 s_retbool (0);
4655
4656 v = nvalue (car (x));
4657 }
4658
4659 s_retbool (1);
4660
4661 case OP_SYMBOLP: /* symbol? */
4662 s_retbool (is_symbol (car (SCHEME_V->args)));
4663
4664 case OP_NUMBERP: /* number? */
4665 s_retbool (is_number (car (SCHEME_V->args)));
4666
4667 case OP_STRINGP: /* string? */
4668 s_retbool (is_string (car (SCHEME_V->args)));
4669
4670 case OP_INTEGERP: /* integer? */
4671 s_retbool (is_integer (car (SCHEME_V->args)));
4672
4673 case OP_REALP: /* real? */
4674 s_retbool (is_number (car (SCHEME_V->args))); /* All numbers are real */
4675
4676 case OP_CHARP: /* char? */
4677 s_retbool (is_character (car (SCHEME_V->args)));
4678#if USE_CHAR_CLASSIFIERS 4552#if USE_CHAR_CLASSIFIERS
4679 4553 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4680 case OP_CHARAP: /* char-alphabetic? */ 4554 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4681 s_retbool (Cisalpha (ivalue (car (SCHEME_V->args)))); 4555 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
4682 4556 case OP_CHARUP: /* char-upper-case? */ r = Cisupper (ivalue_unchecked (a)); break;
4683 case OP_CHARNP: /* char-numeric? */ 4557 case OP_CHARLP: /* char-lower-case? */ r = Cislower (ivalue_unchecked (a)); break;
4684 s_retbool (Cisdigit (ivalue (car (SCHEME_V->args))));
4685
4686 case OP_CHARWP: /* char-whitespace? */
4687 s_retbool (Cisspace (ivalue (car (SCHEME_V->args))));
4688
4689 case OP_CHARUP: /* char-upper-case? */
4690 s_retbool (Cisupper (ivalue (car (SCHEME_V->args))));
4691
4692 case OP_CHARLP: /* char-lower-case? */
4693 s_retbool (Cislower (ivalue (car (SCHEME_V->args))));
4694#endif 4558#endif
4559
4695#if USE_PORTS 4560#if USE_PORTS
4696 4561 case OP_PORTP: /* port? */ r = is_port (a) ; break;
4697 case OP_PORTP: /* port? */
4698 s_retbool (is_port (car (SCHEME_V->args)));
4699
4700 case OP_INPORTP: /* input-port? */ 4562 case OP_INPORTP: /* input-port? */ r = is_inport (a) ; break;
4701 s_retbool (is_inport (car (SCHEME_V->args)));
4702
4703 case OP_OUTPORTP: /* output-port? */ 4563 case OP_OUTPORTP: /* output-port? */ r = is_outport (a); break;
4704 s_retbool (is_outport (car (SCHEME_V->args)));
4705#endif 4564#endif
4706 4565
4707 case OP_PROCP: /* procedure? */ 4566 case OP_PROCP: /* procedure? */
4708 4567
4709 /*-- 4568 /*--
4710 * continuation should be procedure by the example 4569 * continuation should be procedure by the example
4711 * (call-with-current-continuation procedure?) ==> #t 4570 * (call-with-current-continuation procedure?) ==> #t
4712 * in R^3 report sec. 6.9 4571 * in R^3 report sec. 6.9
4713 */ 4572 */
4714 s_retbool (is_proc (car (SCHEME_V->args)) || is_closure (car (SCHEME_V->args)) 4573 r = is_proc (a) || is_closure (a) || is_continuation (a) || is_foreign (a);
4715 || is_continuation (car (SCHEME_V->args)) || is_foreign (car (SCHEME_V->args))); 4574 break;
4716 4575
4717 case OP_PAIRP: /* pair? */ 4576 case OP_PAIRP: /* pair? */ r = is_pair (a) ; break;
4718 s_retbool (is_pair (car (SCHEME_V->args))); 4577 case OP_LISTP: /* list? */ r = list_length (SCHEME_A_ a) >= 0; break;
4719 4578 case OP_ENVP: /* environment? */ r = is_environment (a) ; break;
4720 case OP_LISTP: /* list? */ 4579 case OP_VECTORP: /* vector? */ r = is_vector (a) ; break;
4721 s_retbool (list_length (SCHEME_A_ car (SCHEME_V->args)) >= 0); 4580 case OP_EQ: /* eq? */ r = a == cadr (args) ; break;
4722 4581 case OP_EQV: /* eqv? */ r = eqv (a, cadr (args)) ; break;
4723 case OP_ENVP: /* environment? */
4724 s_retbool (is_environment (car (SCHEME_V->args)));
4725
4726 case OP_VECTORP: /* vector? */
4727 s_retbool (is_vector (car (SCHEME_V->args)));
4728
4729 case OP_EQ: /* eq? */
4730 s_retbool (car (SCHEME_V->args) == cadr (SCHEME_V->args));
4731
4732 case OP_EQV: /* eqv? */
4733 s_retbool (eqv (car (SCHEME_V->args), cadr (SCHEME_V->args)));
4734 } 4582 }
4735 4583
4736 return S_T; 4584 s_retbool (r);
4737} 4585}
4738 4586
4739static pointer 4587/* promises, list ops, ports */
4588ecb_hot static int
4740opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4589opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4741{ 4590{
4591 pointer args = SCHEME_V->args;
4592 pointer a = car (args);
4742 pointer x, y; 4593 pointer x, y;
4743 4594
4744 switch (op) 4595 switch (op)
4745 { 4596 {
4746 case OP_FORCE: /* force */ 4597 case OP_FORCE: /* force */
4747 SCHEME_V->code = car (SCHEME_V->args); 4598 SCHEME_V->code = a;
4748 4599
4749 if (is_promise (SCHEME_V->code)) 4600 if (is_promise (SCHEME_V->code))
4750 { 4601 {
4751 /* Should change type to closure here */ 4602 /* Should change type to closure here */
4752 s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code); 4603 s_save (SCHEME_A_ OP_SAVE_FORCED, NIL, SCHEME_V->code);
… …
4755 } 4606 }
4756 else 4607 else
4757 s_return (SCHEME_V->code); 4608 s_return (SCHEME_V->code);
4758 4609
4759 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4610 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4760 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4611 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4761 s_return (SCHEME_V->value); 4612 s_return (SCHEME_V->value);
4762 4613
4763#if USE_PORTS 4614#if USE_PORTS
4615
4616 case OP_EOF_OBJECT: /* eof-object */
4617 s_return (S_EOF);
4764 4618
4765 case OP_WRITE: /* write */ 4619 case OP_WRITE: /* write */
4766 case OP_DISPLAY: /* display */ 4620 case OP_DISPLAY: /* display */
4767 case OP_WRITE_CHAR: /* write-char */ 4621 case OP_WRITE_CHAR: /* write-char */
4768 if (is_pair (cdr (SCHEME_V->args))) 4622 if (is_pair (cdr (SCHEME_V->args)))
… …
4773 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4627 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4774 SCHEME_V->outport = cadr (SCHEME_V->args); 4628 SCHEME_V->outport = cadr (SCHEME_V->args);
4775 } 4629 }
4776 } 4630 }
4777 4631
4778 SCHEME_V->args = car (SCHEME_V->args); 4632 SCHEME_V->args = a;
4779 4633
4780 if (op == OP_WRITE) 4634 if (op == OP_WRITE)
4781 SCHEME_V->print_flag = 1; 4635 SCHEME_V->print_flag = 1;
4782 else 4636 else
4783 SCHEME_V->print_flag = 0; 4637 SCHEME_V->print_flag = 0;
4784 4638
4785 s_goto (OP_P0LIST); 4639 s_goto (OP_P0LIST);
4786 4640
4787 case OP_NEWLINE: /* newline */ 4641 case OP_NEWLINE: /* newline */
4788 if (is_pair (SCHEME_V->args)) 4642 if (is_pair (args))
4789 { 4643 {
4790 if (car (SCHEME_V->args) != SCHEME_V->outport) 4644 if (a != SCHEME_V->outport)
4791 { 4645 {
4792 x = cons (SCHEME_V->outport, NIL); 4646 x = cons (SCHEME_V->outport, NIL);
4793 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4647 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4794 SCHEME_V->outport = car (SCHEME_V->args); 4648 SCHEME_V->outport = a;
4795 } 4649 }
4796 } 4650 }
4797 4651
4798 putstr (SCHEME_A_ "\n"); 4652 putstr (SCHEME_A_ "\n");
4799 s_return (S_T); 4653 s_return (S_T);
4800#endif 4654#endif
4801 4655
4802 case OP_ERR0: /* error */ 4656 case OP_ERR0: /* error */
4803 SCHEME_V->retcode = -1; 4657 SCHEME_V->retcode = -1;
4804 4658
4805 if (!is_string (car (SCHEME_V->args))) 4659 if (!is_string (a))
4806 { 4660 {
4807 SCHEME_V->args = cons (mk_string (SCHEME_A_ " -- "), SCHEME_V->args); 4661 args = cons (mk_string (SCHEME_A_ " -- "), args);
4808 setimmutable (car (SCHEME_V->args)); 4662 setimmutable (car (args));
4809 } 4663 }
4810 4664
4811 putstr (SCHEME_A_ "Error: "); 4665 putstr (SCHEME_A_ "Error: ");
4812 putstr (SCHEME_A_ strvalue (car (SCHEME_V->args))); 4666 putstr (SCHEME_A_ strvalue (car (args)));
4813 SCHEME_V->args = cdr (SCHEME_V->args); 4667 SCHEME_V->args = cdr (args);
4814 s_goto (OP_ERR1); 4668 s_goto (OP_ERR1);
4815 4669
4816 case OP_ERR1: /* error */ 4670 case OP_ERR1: /* error */
4817 putstr (SCHEME_A_ " "); 4671 putstr (SCHEME_A_ " ");
4818 4672
4819 if (SCHEME_V->args != NIL) 4673 if (args != NIL)
4820 { 4674 {
4821 s_save (SCHEME_A_ OP_ERR1, cdr (SCHEME_V->args), NIL); 4675 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4822 SCHEME_V->args = car (SCHEME_V->args); 4676 SCHEME_V->args = a;
4823 SCHEME_V->print_flag = 1; 4677 SCHEME_V->print_flag = 1;
4824 s_goto (OP_P0LIST); 4678 s_goto (OP_P0LIST);
4825 } 4679 }
4826 else 4680 else
4827 { 4681 {
4828 putstr (SCHEME_A_ "\n"); 4682 putstr (SCHEME_A_ "\n");
4829 4683
4830 if (SCHEME_V->interactive_repl) 4684 if (SCHEME_V->interactive_repl)
4831 s_goto (OP_T0LVL); 4685 s_goto (OP_T0LVL);
4832 else 4686 else
4833 return NIL; 4687 return -1;
4834 } 4688 }
4835 4689
4836 case OP_REVERSE: /* reverse */ 4690 case OP_REVERSE: /* reverse */
4837 s_return (reverse (SCHEME_A_ car (SCHEME_V->args))); 4691 s_return (reverse (SCHEME_A_ a));
4838 4692
4839 case OP_LIST_STAR: /* list* */ 4693 case OP_LIST_STAR: /* list* */
4840 s_return (list_star (SCHEME_A_ SCHEME_V->args)); 4694 s_return (list_star (SCHEME_A_ SCHEME_V->args));
4841 4695
4842 case OP_APPEND: /* append */ 4696 case OP_APPEND: /* append */
4843 x = NIL; 4697 x = NIL;
4844 y = SCHEME_V->args; 4698 y = args;
4845 4699
4846 if (y == x) 4700 if (y == x)
4847 s_return (x); 4701 s_return (x);
4848 4702
4849 /* cdr() in the while condition is not a typo. If car() */ 4703 /* cdr() in the while condition is not a typo. If car() */
… …
4860 s_return (reverse_in_place (SCHEME_A_ car (y), x)); 4714 s_return (reverse_in_place (SCHEME_A_ car (y), x));
4861 4715
4862#if USE_PLIST 4716#if USE_PLIST
4863 4717
4864 case OP_PUT: /* put */ 4718 case OP_PUT: /* put */
4865 if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) 4719 if (!hasprop (a) || !hasprop (cadr (args)))
4866 Error_0 ("illegal use of put"); 4720 Error_0 ("illegal use of put");
4867 4721
4868 for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) 4722 for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
4869 { 4723 {
4870 if (caar (x) == y) 4724 if (caar (x) == y)
4871 break; 4725 break;
4872 } 4726 }
4873 4727
4874 if (x != NIL) 4728 if (x != NIL)
4875 cdar (x) = caddr (SCHEME_V->args); 4729 cdar (x) = caddr (args);
4876 else 4730 else
4877 symprop (car (SCHEME_V->args)) = cons (cons (y, caddr (SCHEME_V->args)), symprop (car (SCHEME_V->args))); 4731 symprop (a) = cons (cons (y, caddr (args)), symprop (a));
4878 4732
4879 s_return (S_T); 4733 s_return (S_T);
4880 4734
4881 case OP_GET: /* get */ 4735 case OP_GET: /* get */
4882 if (!hasprop (car (SCHEME_V->args)) || !hasprop (cadr (SCHEME_V->args))) 4736 if (!hasprop (a) || !hasprop (cadr (args)))
4883 Error_0 ("illegal use of get"); 4737 Error_0 ("illegal use of get");
4884 4738
4885 for (x = symprop (car (SCHEME_V->args)), y = cadr (SCHEME_V->args); x != NIL; x = cdr (x)) 4739 for (x = symprop (a), y = cadr (args); x != NIL; x = cdr (x))
4886 if (caar (x) == y) 4740 if (caar (x) == y)
4887 break; 4741 break;
4888 4742
4889 if (x != NIL) 4743 if (x != NIL)
4890 s_return (cdar (x)); 4744 s_return (cdar (x));
… …
4892 s_return (NIL); 4746 s_return (NIL);
4893 4747
4894#endif /* USE_PLIST */ 4748#endif /* USE_PLIST */
4895 4749
4896 case OP_QUIT: /* quit */ 4750 case OP_QUIT: /* quit */
4897 if (is_pair (SCHEME_V->args)) 4751 if (is_pair (args))
4898 SCHEME_V->retcode = ivalue (car (SCHEME_V->args)); 4752 SCHEME_V->retcode = ivalue (a);
4899 4753
4900 return NIL; 4754 return -1;
4901 4755
4902 case OP_GC: /* gc */ 4756 case OP_GC: /* gc */
4903 gc (SCHEME_A_ NIL, NIL); 4757 gc (SCHEME_A_ NIL, NIL);
4904 s_return (S_T); 4758 s_return (S_T);
4905 4759
4906 case OP_GCVERB: /* gc-verbose */ 4760 case OP_GCVERB: /* gc-verbose */
4907 { 4761 {
4908 int was = SCHEME_V->gc_verbose; 4762 int was = SCHEME_V->gc_verbose;
4909 4763
4910 SCHEME_V->gc_verbose = (car (SCHEME_V->args) != S_F); 4764 SCHEME_V->gc_verbose = (a != S_F);
4911 s_retbool (was); 4765 s_retbool (was);
4912 } 4766 }
4913 4767
4914 case OP_NEWSEGMENT: /* new-segment */ 4768 case OP_NEWSEGMENT: /* new-segment */
4769#if 0
4915 if (!is_pair (SCHEME_V->args) || !is_number (car (SCHEME_V->args))) 4770 if (!is_pair (args) || !is_number (a))
4916 Error_0 ("new-segment: argument must be a number"); 4771 Error_0 ("new-segment: argument must be a number");
4917 4772#endif
4918 alloc_cellseg (SCHEME_A_ (int)ivalue (car (SCHEME_V->args))); 4773 s_retbool (alloc_cellseg (SCHEME_A));
4919
4920 s_return (S_T);
4921 4774
4922 case OP_OBLIST: /* oblist */ 4775 case OP_OBLIST: /* oblist */
4923 s_return (oblist_all_symbols (SCHEME_A)); 4776 s_return (oblist_all_symbols (SCHEME_A));
4924 4777
4925#if USE_PORTS 4778#if USE_PORTS
… …
4950 case OP_OPEN_INOUTFILE: 4803 case OP_OPEN_INOUTFILE:
4951 prop = port_input | port_output; 4804 prop = port_input | port_output;
4952 break; 4805 break;
4953 } 4806 }
4954 4807
4955 p = port_from_filename (SCHEME_A_ strvalue (car (SCHEME_V->args)), prop); 4808 p = port_from_filename (SCHEME_A_ strvalue (a), prop);
4956 4809
4957 if (p == NIL) 4810 s_return (p == NIL ? S_F : p);
4958 s_return (S_F);
4959
4960 s_return (p);
4961 } 4811 }
4962 4812
4963# if USE_STRING_PORTS 4813# if USE_STRING_PORTS
4964 4814
4965 case OP_OPEN_INSTRING: /* open-input-string */ 4815 case OP_OPEN_INSTRING: /* open-input-string */
… …
4977 case OP_OPEN_INOUTSTRING: 4827 case OP_OPEN_INOUTSTRING:
4978 prop = port_input | port_output; 4828 prop = port_input | port_output;
4979 break; 4829 break;
4980 } 4830 }
4981 4831
4982 p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), 4832 p = port_from_string (SCHEME_A_ strvalue (a),
4983 strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), prop); 4833 strvalue (a) + strlength (a), prop);
4984 4834
4985 if (p == NIL) 4835 s_return (p == NIL ? S_F : p);
4986 s_return (S_F);
4987
4988 s_return (p);
4989 } 4836 }
4990 4837
4991 case OP_OPEN_OUTSTRING: /* open-output-string */ 4838 case OP_OPEN_OUTSTRING: /* open-output-string */
4992 { 4839 {
4993 pointer p; 4840 pointer p;
4994 4841
4995 if (car (SCHEME_V->args) == NIL) 4842 if (a == NIL)
4996 {
4997 p = port_from_scratch (SCHEME_A); 4843 p = port_from_scratch (SCHEME_A);
4998
4999 if (p == NIL)
5000 s_return (S_F);
5001 }
5002 else 4844 else
5003 {
5004 p = port_from_string (SCHEME_A_ strvalue (car (SCHEME_V->args)), 4845 p = port_from_string (SCHEME_A_ strvalue (a),
5005 strvalue (car (SCHEME_V->args)) + strlength (car (SCHEME_V->args)), port_output); 4846 strvalue (a) + strlength (a), port_output);
5006 4847
5007 if (p == NIL) 4848 s_return (p == NIL ? S_F : p);
5008 s_return (S_F);
5009 }
5010
5011 s_return (p);
5012 } 4849 }
5013 4850
5014 case OP_GET_OUTSTRING: /* get-output-string */ 4851 case OP_GET_OUTSTRING: /* get-output-string */
5015 { 4852 {
5016 port *p; 4853 port *p = port (a);
5017 4854
5018 if ((p = car (SCHEME_V->args)->object.port)->kind & port_string) 4855 if (p->kind & port_string)
5019 { 4856 {
5020 off_t size; 4857 off_t size;
5021 char *str; 4858 char *str;
5022 4859
5023 size = p->rep.string.curr - p->rep.string.start + 1; 4860 size = p->rep.string.curr - p->rep.string.start + 1;
… …
5039 } 4876 }
5040 4877
5041# endif 4878# endif
5042 4879
5043 case OP_CLOSE_INPORT: /* close-input-port */ 4880 case OP_CLOSE_INPORT: /* close-input-port */
5044 port_close (SCHEME_A_ car (SCHEME_V->args), port_input); 4881 port_close (SCHEME_A_ a, port_input);
5045 s_return (S_T); 4882 s_return (S_T);
5046 4883
5047 case OP_CLOSE_OUTPORT: /* close-output-port */ 4884 case OP_CLOSE_OUTPORT: /* close-output-port */
5048 port_close (SCHEME_A_ car (SCHEME_V->args), port_output); 4885 port_close (SCHEME_A_ a, port_output);
5049 s_return (S_T); 4886 s_return (S_T);
5050#endif 4887#endif
5051 4888
5052 case OP_INT_ENV: /* interaction-environment */ 4889 case OP_INT_ENV: /* interaction-environment */
5053 s_return (SCHEME_V->global_env); 4890 s_return (SCHEME_V->global_env);
… …
5055 case OP_CURR_ENV: /* current-environment */ 4892 case OP_CURR_ENV: /* current-environment */
5056 s_return (SCHEME_V->envir); 4893 s_return (SCHEME_V->envir);
5057 4894
5058 } 4895 }
5059 4896
5060 return S_T; 4897 if (USE_ERROR_CHECKING) abort ();
5061} 4898}
5062 4899
5063static pointer 4900/* reading */
4901ecb_cold static int
5064opexe_5 (SCHEME_P_ enum scheme_opcodes op) 4902opexe_5 (SCHEME_P_ enum scheme_opcodes op)
5065{ 4903{
4904 pointer args = SCHEME_V->args;
5066 pointer x; 4905 pointer x;
5067 4906
5068 if (SCHEME_V->nesting != 0) 4907 if (SCHEME_V->nesting != 0)
5069 { 4908 {
5070 int n = SCHEME_V->nesting; 4909 int n = SCHEME_V->nesting;
… …
5077 switch (op) 4916 switch (op)
5078 { 4917 {
5079 /* ========== reading part ========== */ 4918 /* ========== reading part ========== */
5080#if USE_PORTS 4919#if USE_PORTS
5081 case OP_READ: 4920 case OP_READ:
5082 if (!is_pair (SCHEME_V->args)) 4921 if (!is_pair (args))
5083 s_goto (OP_READ_INTERNAL); 4922 s_goto (OP_READ_INTERNAL);
5084 4923
5085 if (!is_inport (car (SCHEME_V->args))) 4924 if (!is_inport (car (args)))
5086 Error_1 ("read: not an input port:", car (SCHEME_V->args)); 4925 Error_1 ("read: not an input port:", car (args));
5087 4926
5088 if (car (SCHEME_V->args) == SCHEME_V->inport) 4927 if (car (args) == SCHEME_V->inport)
5089 s_goto (OP_READ_INTERNAL); 4928 s_goto (OP_READ_INTERNAL);
5090 4929
5091 x = SCHEME_V->inport; 4930 x = SCHEME_V->inport;
5092 SCHEME_V->inport = car (SCHEME_V->args); 4931 SCHEME_V->inport = car (args);
5093 x = cons (x, NIL); 4932 x = cons (x, NIL);
5094 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); 4933 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
5095 s_goto (OP_READ_INTERNAL); 4934 s_goto (OP_READ_INTERNAL);
5096 4935
5097 case OP_READ_CHAR: /* read-char */ 4936 case OP_READ_CHAR: /* read-char */
5098 case OP_PEEK_CHAR: /* peek-char */ 4937 case OP_PEEK_CHAR: /* peek-char */
5099 { 4938 {
5100 int c; 4939 int c;
5101 4940
5102 if (is_pair (SCHEME_V->args)) 4941 if (is_pair (args))
5103 { 4942 {
5104 if (car (SCHEME_V->args) != SCHEME_V->inport) 4943 if (car (args) != SCHEME_V->inport)
5105 { 4944 {
5106 x = SCHEME_V->inport; 4945 x = SCHEME_V->inport;
5107 x = cons (x, NIL); 4946 x = cons (x, NIL);
5108 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL); 4947 s_save (SCHEME_A_ OP_SET_INPORT, x, NIL);
5109 SCHEME_V->inport = car (SCHEME_V->args); 4948 SCHEME_V->inport = car (args);
5110 } 4949 }
5111 } 4950 }
5112 4951
5113 c = inchar (SCHEME_A); 4952 c = inchar (SCHEME_A);
5114 4953
… …
5124 case OP_CHAR_READY: /* char-ready? */ 4963 case OP_CHAR_READY: /* char-ready? */
5125 { 4964 {
5126 pointer p = SCHEME_V->inport; 4965 pointer p = SCHEME_V->inport;
5127 int res; 4966 int res;
5128 4967
5129 if (is_pair (SCHEME_V->args)) 4968 if (is_pair (args))
5130 p = car (SCHEME_V->args); 4969 p = car (args);
5131 4970
5132 res = p->object.port->kind & port_string; 4971 res = port (p)->kind & port_string;
5133 4972
5134 s_retbool (res); 4973 s_retbool (res);
5135 } 4974 }
5136 4975
5137 case OP_SET_INPORT: /* set-input-port */ 4976 case OP_SET_INPORT: /* set-input-port */
5138 SCHEME_V->inport = car (SCHEME_V->args); 4977 SCHEME_V->inport = car (args);
5139 s_return (SCHEME_V->value); 4978 s_return (SCHEME_V->value);
5140 4979
5141 case OP_SET_OUTPORT: /* set-output-port */ 4980 case OP_SET_OUTPORT: /* set-output-port */
5142 SCHEME_V->outport = car (SCHEME_V->args); 4981 SCHEME_V->outport = car (args);
5143 s_return (SCHEME_V->value); 4982 s_return (SCHEME_V->value);
5144#endif 4983#endif
5145 4984
5146 case OP_RDSEXPR: 4985 case OP_RDSEXPR:
5147 switch (SCHEME_V->tok) 4986 switch (SCHEME_V->tok)
… …
5196 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL); 5035 s_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
5197 SCHEME_V->tok = token (SCHEME_A); 5036 SCHEME_V->tok = token (SCHEME_A);
5198 s_goto (OP_RDSEXPR); 5037 s_goto (OP_RDSEXPR);
5199 5038
5200 case TOK_ATOM: 5039 case TOK_ATOM:
5201 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))); 5040 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));
5041
5042 case TOK_DOTATOM:
5043 SCHEME_V->strbuff[0] = '.';
5044 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5045
5046 case TOK_STRATOM:
5047 x = readstrexp (SCHEME_A_ '|');
5048 //TODO: haven't checked whether the garbage collector could interfere
5049 s_return (mk_atom (SCHEME_A_ strvalue (x)));
5202 5050
5203 case TOK_DQUOTE: 5051 case TOK_DQUOTE:
5204 x = readstrexp (SCHEME_A); 5052 x = readstrexp (SCHEME_A_ '"');
5205 5053
5206 if (x == S_F) 5054 if (x == S_F)
5207 Error_0 ("Error reading string"); 5055 Error_0 ("Error reading string");
5208 5056
5209 setimmutable (x); 5057 setimmutable (x);
… …
5221 s_goto (OP_EVAL); 5069 s_goto (OP_EVAL);
5222 } 5070 }
5223 } 5071 }
5224 5072
5225 case TOK_SHARP_CONST: 5073 case TOK_SHARP_CONST:
5226 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL) 5074 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5227 Error_0 ("undefined sharp expression"); 5075 Error_0 ("undefined sharp expression");
5228 else 5076 else
5229 s_return (x); 5077 s_return (x);
5230 5078
5231 default: 5079 default:
… …
5233 } 5081 }
5234 5082
5235 break; 5083 break;
5236 5084
5237 case OP_RDLIST: 5085 case OP_RDLIST:
5238 SCHEME_V->args = cons (SCHEME_V->value, SCHEME_V->args); 5086 SCHEME_V->args = cons (SCHEME_V->value, args);
5239 SCHEME_V->tok = token (SCHEME_A); 5087 SCHEME_V->tok = token (SCHEME_A);
5240 5088
5241 switch (SCHEME_V->tok) 5089 switch (SCHEME_V->tok)
5242 { 5090 {
5243 case TOK_EOF: 5091 case TOK_EOF:
… …
5271 case OP_RDDOT: 5119 case OP_RDDOT:
5272 if (token (SCHEME_A) != TOK_RPAREN) 5120 if (token (SCHEME_A) != TOK_RPAREN)
5273 Error_0 ("syntax error: illegal dot expression"); 5121 Error_0 ("syntax error: illegal dot expression");
5274 5122
5275 SCHEME_V->nesting_stack[SCHEME_V->file_i]--; 5123 SCHEME_V->nesting_stack[SCHEME_V->file_i]--;
5276 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, SCHEME_V->args)); 5124 s_return (reverse_in_place (SCHEME_A_ SCHEME_V->value, args));
5277 5125
5278 case OP_RDQUOTE: 5126 case OP_RDQUOTE:
5279 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL))); 5127 s_return (cons (SCHEME_V->QUOTE, cons (SCHEME_V->value, NIL)));
5280 5128
5281 case OP_RDQQUOTE: 5129 case OP_RDQQUOTE:
… …
5303 SCHEME_V->args = SCHEME_V->value; 5151 SCHEME_V->args = SCHEME_V->value;
5304 s_goto (OP_VECTOR); 5152 s_goto (OP_VECTOR);
5305 5153
5306 /* ========== printing part ========== */ 5154 /* ========== printing part ========== */
5307 case OP_P0LIST: 5155 case OP_P0LIST:
5308 if (is_vector (SCHEME_V->args)) 5156 if (is_vector (args))
5309 { 5157 {
5310 putstr (SCHEME_A_ "#("); 5158 putstr (SCHEME_A_ "#(");
5311 SCHEME_V->args = cons (SCHEME_V->args, mk_integer (SCHEME_A_ 0)); 5159 SCHEME_V->args = cons (args, mk_integer (SCHEME_A_ 0));
5312 s_goto (OP_PVECFROM); 5160 s_goto (OP_PVECFROM);
5313 } 5161 }
5314 else if (is_environment (SCHEME_V->args)) 5162 else if (is_environment (args))
5315 { 5163 {
5316 putstr (SCHEME_A_ "#<ENVIRONMENT>"); 5164 putstr (SCHEME_A_ "#<ENVIRONMENT>");
5317 s_return (S_T); 5165 s_return (S_T);
5318 } 5166 }
5319 else if (!is_pair (SCHEME_V->args)) 5167 else if (!is_pair (args))
5320 { 5168 {
5321 printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); 5169 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5322 s_return (S_T); 5170 s_return (S_T);
5323 } 5171 }
5324 else if (car (SCHEME_V->args) == SCHEME_V->QUOTE && ok_abbrev (cdr (SCHEME_V->args))) 5172 else
5325 { 5173 {
5174 pointer a = car (args);
5175 pointer b = cdr (args);
5176 int ok_abbr = ok_abbrev (b);
5177 SCHEME_V->args = car (b);
5178
5179 if (a == SCHEME_V->QUOTE && ok_abbr)
5326 putstr (SCHEME_A_ "'"); 5180 putstr (SCHEME_A_ "'");
5327 SCHEME_V->args = cadr (SCHEME_V->args); 5181 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5182 putstr (SCHEME_A_ "`");
5183 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5184 putstr (SCHEME_A_ ",");
5185 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5186 putstr (SCHEME_A_ ",@");
5187 else
5188 {
5189 putstr (SCHEME_A_ "(");
5190 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5191 SCHEME_V->args = a;
5192 }
5193
5328 s_goto (OP_P0LIST); 5194 s_goto (OP_P0LIST);
5329 } 5195 }
5330 else if (car (SCHEME_V->args) == SCHEME_V->QQUOTE && ok_abbrev (cdr (SCHEME_V->args))) 5196
5197 case OP_P1LIST:
5198 if (is_pair (args))
5331 { 5199 {
5200 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5332 putstr (SCHEME_A_ "`"); 5201 putstr (SCHEME_A_ " ");
5333 SCHEME_V->args = cadr (SCHEME_V->args); 5202 SCHEME_V->args = car (args);
5334 s_goto (OP_P0LIST); 5203 s_goto (OP_P0LIST);
5335 } 5204 }
5336 else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTE && ok_abbrev (cdr (SCHEME_V->args)))
5337 {
5338 putstr (SCHEME_A_ ",");
5339 SCHEME_V->args = cadr (SCHEME_V->args);
5340 s_goto (OP_P0LIST);
5341 }
5342 else if (car (SCHEME_V->args) == SCHEME_V->UNQUOTESP && ok_abbrev (cdr (SCHEME_V->args)))
5343 {
5344 putstr (SCHEME_A_ ",@");
5345 SCHEME_V->args = cadr (SCHEME_V->args);
5346 s_goto (OP_P0LIST);
5347 }
5348 else
5349 {
5350 putstr (SCHEME_A_ "(");
5351 s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
5352 SCHEME_V->args = car (SCHEME_V->args);
5353 s_goto (OP_P0LIST);
5354 }
5355
5356 case OP_P1LIST:
5357 if (is_pair (SCHEME_V->args))
5358 {
5359 s_save (SCHEME_A_ OP_P1LIST, cdr (SCHEME_V->args), NIL);
5360 putstr (SCHEME_A_ " ");
5361 SCHEME_V->args = car (SCHEME_V->args);
5362 s_goto (OP_P0LIST);
5363 }
5364 else if (is_vector (SCHEME_V->args)) 5205 else if (is_vector (args))
5365 { 5206 {
5366 s_save (SCHEME_A_ OP_P1LIST, NIL, NIL); 5207 s_save (SCHEME_A_ OP_P1LIST, NIL, NIL);
5367 putstr (SCHEME_A_ " . "); 5208 putstr (SCHEME_A_ " . ");
5368 s_goto (OP_P0LIST); 5209 s_goto (OP_P0LIST);
5369 } 5210 }
5370 else 5211 else
5371 { 5212 {
5372 if (SCHEME_V->args != NIL) 5213 if (args != NIL)
5373 { 5214 {
5374 putstr (SCHEME_A_ " . "); 5215 putstr (SCHEME_A_ " . ");
5375 printatom (SCHEME_A_ SCHEME_V->args, SCHEME_V->print_flag); 5216 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5376 } 5217 }
5377 5218
5378 putstr (SCHEME_A_ ")"); 5219 putstr (SCHEME_A_ ")");
5379 s_return (S_T); 5220 s_return (S_T);
5380 } 5221 }
5381 5222
5382 case OP_PVECFROM: 5223 case OP_PVECFROM:
5383 { 5224 {
5384 int i = ivalue_unchecked (cdr (SCHEME_V->args)); 5225 int i = ivalue_unchecked (cdr (args));
5385 pointer vec = car (SCHEME_V->args); 5226 pointer vec = car (args);
5386 int len = vector_length (vec); 5227 int len = veclength (vec);
5387 5228
5388 if (i == len) 5229 if (i == len)
5389 { 5230 {
5390 putstr (SCHEME_A_ ")"); 5231 putstr (SCHEME_A_ ")");
5391 s_return (S_T); 5232 s_return (S_T);
5392 } 5233 }
5393 else 5234 else
5394 { 5235 {
5395 pointer elem = vector_elem (vec, i); 5236 pointer elem = vector_get (vec, i);
5396 5237
5397 ivalue_unchecked (cdr (SCHEME_V->args)) = i + 1; 5238 ivalue_unchecked (cdr (args)) = i + 1;
5398 s_save (SCHEME_A_ OP_PVECFROM, SCHEME_V->args, NIL); 5239 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5399 SCHEME_V->args = elem; 5240 SCHEME_V->args = elem;
5400 5241
5401 if (i > 0) 5242 if (i > 0)
5402 putstr (SCHEME_A_ " "); 5243 putstr (SCHEME_A_ " ");
5403 5244
5404 s_goto (OP_P0LIST); 5245 s_goto (OP_P0LIST);
5405 } 5246 }
5406 } 5247 }
5407 } 5248 }
5408 5249
5409 return S_T; 5250 if (USE_ERROR_CHECKING) abort ();
5410} 5251}
5411 5252
5412static pointer 5253/* list ops */
5254ecb_hot static int
5413opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5255opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5414{ 5256{
5257 pointer args = SCHEME_V->args;
5258 pointer a = car (args);
5415 pointer x, y; 5259 pointer x, y;
5416 5260
5417 switch (op) 5261 switch (op)
5418 { 5262 {
5419 case OP_LIST_LENGTH: /* length *//* a.k */ 5263 case OP_LIST_LENGTH: /* length *//* a.k */
5420 { 5264 {
5421 long v = list_length (SCHEME_A_ car (SCHEME_V->args)); 5265 long v = list_length (SCHEME_A_ a);
5422 5266
5423 if (v < 0) 5267 if (v < 0)
5424 Error_1 ("length: not a list:", car (SCHEME_V->args)); 5268 Error_1 ("length: not a list:", a);
5425 5269
5426 s_return (mk_integer (SCHEME_A_ v)); 5270 s_return (mk_integer (SCHEME_A_ v));
5427 } 5271 }
5428 5272
5429 case OP_ASSQ: /* assq *//* a.k */ 5273 case OP_ASSQ: /* assq *//* a.k */
5430 x = car (SCHEME_V->args); 5274 x = a;
5431 5275
5432 for (y = cadr (SCHEME_V->args); is_pair (y); y = cdr (y)) 5276 for (y = cadr (args); is_pair (y); y = cdr (y))
5433 { 5277 {
5434 if (!is_pair (car (y))) 5278 if (!is_pair (car (y)))
5435 Error_0 ("unable to handle non pair element"); 5279 Error_0 ("unable to handle non pair element");
5436 5280
5437 if (x == caar (y)) 5281 if (x == caar (y))
… …
5443 else 5287 else
5444 s_return (S_F); 5288 s_return (S_F);
5445 5289
5446 5290
5447 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5291 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5448 SCHEME_V->args = car (SCHEME_V->args); 5292 SCHEME_V->args = a;
5449 5293
5450 if (SCHEME_V->args == NIL) 5294 if (SCHEME_V->args == NIL)
5451 s_return (S_F); 5295 s_return (S_F);
5452 else if (is_closure (SCHEME_V->args)) 5296 else if (is_closure (SCHEME_V->args))
5453 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5297 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
… …
5458 5302
5459 case OP_CLOSUREP: /* closure? */ 5303 case OP_CLOSUREP: /* closure? */
5460 /* 5304 /*
5461 * Note, macro object is also a closure. 5305 * Note, macro object is also a closure.
5462 * Therefore, (closure? <#MACRO>) ==> #t 5306 * Therefore, (closure? <#MACRO>) ==> #t
5307 * (schmorp) well, obviously not, fix? TODO
5463 */ 5308 */
5464 s_retbool (is_closure (car (SCHEME_V->args))); 5309 s_retbool (is_closure (a));
5465 5310
5466 case OP_MACROP: /* macro? */ 5311 case OP_MACROP: /* macro? */
5467 s_retbool (is_macro (car (SCHEME_V->args))); 5312 s_retbool (is_macro (a));
5468 } 5313 }
5469 5314
5470 return S_T; /* NOTREACHED */ 5315 if (USE_ERROR_CHECKING) abort ();
5471} 5316}
5472 5317
5318/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5473typedef pointer (*dispatch_func) (SCHEME_P_ enum scheme_opcodes); 5319typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5474 5320
5475typedef int (*test_predicate) (pointer); 5321typedef int (*test_predicate)(pointer);
5476static int 5322
5323ecb_hot static int
5477is_any (pointer p) 5324tst_any (pointer p)
5478{ 5325{
5479 return 1; 5326 return 1;
5480} 5327}
5481 5328
5482static int 5329ecb_hot static int
5483is_nonneg (pointer p) 5330tst_inonneg (pointer p)
5484{ 5331{
5485 return ivalue (p) >= 0 && is_integer (p); 5332 return is_integer (p) && ivalue_unchecked (p) >= 0;
5333}
5334
5335ecb_hot static int
5336tst_is_list (SCHEME_P_ pointer p)
5337{
5338 return p == NIL || is_pair (p);
5486} 5339}
5487 5340
5488/* Correspond carefully with following defines! */ 5341/* Correspond carefully with following defines! */
5489static struct 5342static struct
5490{ 5343{
5491 test_predicate fct; 5344 test_predicate fct;
5492 const char *kind; 5345 const char *kind;
5493} tests[] = 5346} tests[] = {
5494{ 5347 { tst_any , 0 },
5495 { 0, 0}, /* unused */ 5348 { is_string , "string" },
5496 { is_any, 0}, 5349 { is_symbol , "symbol" },
5497 { is_string, "string" }, 5350 { is_port , "port" },
5498 { is_symbol, "symbol" },
5499 { is_port, "port" },
5500 { is_inport, "input port" }, 5351 { is_inport , "input port" },
5501 { is_outport, "output port" }, 5352 { is_outport , "output port" },
5502 { is_environment, "environment" }, 5353 { is_environment, "environment" },
5503 { is_pair, "pair" }, 5354 { is_pair , "pair" },
5504 { 0, "pair or '()" }, 5355 { 0 , "pair or '()" },
5505 { is_character, "character" }, 5356 { is_character , "character" },
5506 { is_vector, "vector" }, 5357 { is_vector , "vector" },
5507 { is_number, "number" }, 5358 { is_number , "number" },
5508 { is_integer, "integer" }, 5359 { is_integer , "integer" },
5509 { is_nonneg, "non-negative integer" } 5360 { tst_inonneg , "non-negative integer" }
5510}; 5361};
5511 5362
5512#define TST_NONE 0 5363#define TST_NONE 0 /* TST_NONE used for built-ins, 0 for internal ops */
5513#define TST_ANY "\001" 5364#define TST_ANY "\001"
5514#define TST_STRING "\002" 5365#define TST_STRING "\002"
5515#define TST_SYMBOL "\003" 5366#define TST_SYMBOL "\003"
5516#define TST_PORT "\004" 5367#define TST_PORT "\004"
5517#define TST_INPORT "\005" 5368#define TST_INPORT "\005"
5518#define TST_OUTPORT "\006" 5369#define TST_OUTPORT "\006"
5519#define TST_ENVIRONMENT "\007" 5370#define TST_ENVIRONMENT "\007"
5520#define TST_PAIR "\010" 5371#define TST_PAIR "\010"
5521#define TST_LIST "\011" 5372#define TST_LIST "\011"
5522#define TST_CHAR "\012" 5373#define TST_CHAR "\012"
5523#define TST_VECTOR "\013" 5374#define TST_VECTOR "\013"
5524#define TST_NUMBER "\014" 5375#define TST_NUMBER "\014"
5525#define TST_INTEGER "\015" 5376#define TST_INTEGER "\015"
5526#define TST_NATURAL "\016" 5377#define TST_NATURAL "\016"
5378
5379#define INF_ARG 0xff
5380#define UNNAMED_OP ""
5381
5382static const char opnames[] =
5383#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5384#include "opdefines.h"
5385#undef OP_DEF
5386;
5387
5388ecb_cold static const char *
5389opname (int idx)
5390{
5391 const char *name = opnames;
5392
5393 /* should do this at compile time, but would require external program, right? */
5394 while (idx--)
5395 name += strlen (name) + 1;
5396
5397 return *name ? name : "ILLEGAL";
5398}
5399
5400ecb_cold static const char *
5401procname (pointer x)
5402{
5403 return opname (procnum (x));
5404}
5527 5405
5528typedef struct 5406typedef struct
5529{ 5407{
5530 dispatch_func func; 5408 uint8_t func;
5531 char *name; 5409 /*dispatch_func func;*//*TODO: maybe optionally keep the pointer, for speed? */
5410 uint8_t builtin;
5411#if USE_ERROR_CHECKING
5532 int min_arity; 5412 uint8_t min_arity;
5533 int max_arity; 5413 uint8_t max_arity;
5534 char *arg_tests_encoding; 5414 char arg_tests_encoding[3];
5415#endif
5535} op_code_info; 5416} op_code_info;
5536 5417
5537#define INF_ARG 0xffff
5538
5539static op_code_info dispatch_table[] = { 5418static const op_code_info dispatch_table[] = {
5540#define OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, 5419#if USE_ERROR_CHECKING
5420#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1, minarity, maxarity, argtest },
5421#else
5422#define OP_DEF(func,name,minarity,maxarity,argtest,op) { func, sizeof (name) > 1 },
5423#endif
5541#include "opdefines.h" 5424#include "opdefines.h"
5425#undef OP_DEF
5542 {0} 5426 {0}
5543}; 5427};
5544 5428
5545static const char *
5546procname (pointer x)
5547{
5548 int n = procnum (x);
5549 const char *name = dispatch_table[n].name;
5550
5551 if (name == 0)
5552 name = "ILLEGAL!";
5553
5554 return name;
5555}
5556
5557/* kernel of this interpreter */ 5429/* kernel of this interpreter */
5558static void 5430ecb_hot static void
5559Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5431Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5560{ 5432{
5561 SCHEME_V->op = op; 5433 SCHEME_V->op = op;
5562 5434
5563 for (;;) 5435 for (;;)
5564 { 5436 {
5565 op_code_info *pcd = dispatch_table + SCHEME_V->op; 5437 const op_code_info *pcd = dispatch_table + SCHEME_V->op;
5566 5438
5567#if USE_ERROR_CHECKING 5439#if USE_ERROR_CHECKING
5568 if (pcd->name) /* if built-in function, check arguments */ 5440 if (pcd->builtin) /* if built-in function, check arguments */
5569 { 5441 {
5570 int ok = 1;
5571 char msg[STRBUFFSIZE]; 5442 char msg[STRBUFFSIZE];
5572 int n = list_length (SCHEME_A_ SCHEME_V->args); 5443 int n = list_length (SCHEME_A_ SCHEME_V->args);
5573 5444
5574 /* Check number of arguments */ 5445 /* Check number of arguments */
5575 if (n < pcd->min_arity) 5446 if (ecb_expect_false (n < pcd->min_arity))
5576 { 5447 {
5577 ok = 0;
5578 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5448 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5579 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity); 5449 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at least", pcd->min_arity);
5450 xError_1 (SCHEME_A_ msg, 0);
5451 continue;
5580 } 5452 }
5581 5453 else if (ecb_expect_false (n > pcd->max_arity && pcd->max_arity != INF_ARG))
5582 if (ok && n > pcd->max_arity)
5583 { 5454 {
5584 ok = 0;
5585 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", 5455 snprintf (msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
5586 pcd->name, pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity); 5456 opname (SCHEME_V->op), pcd->min_arity == pcd->max_arity ? "" : " at most", pcd->max_arity);
5457 xError_1 (SCHEME_A_ msg, 0);
5458 continue;
5587 } 5459 }
5588 5460 else
5589 if (ok)
5590 { 5461 {
5591 if (pcd->arg_tests_encoding) 5462 if (*pcd->arg_tests_encoding) /* literal 0 and TST_NONE treated the same */
5592 { 5463 {
5593 int i = 0; 5464 int i = 0;
5594 int j; 5465 int j;
5595 const char *t = pcd->arg_tests_encoding; 5466 const char *t = pcd->arg_tests_encoding;
5596 pointer arglist = SCHEME_V->args; 5467 pointer arglist = SCHEME_V->args;
5597 5468
5598 do 5469 do
5599 { 5470 {
5600 pointer arg = car (arglist); 5471 pointer arg = car (arglist);
5601 5472
5602 j = (int) t[0]; 5473 j = t[0];
5603 5474
5475 /*TODO: tst_is_list has different prototype - fix if other tests acquire same prototype */
5604 if (j == TST_LIST[0]) 5476 if (j == TST_LIST[0])
5605 { 5477 {
5606 if (arg != NIL && !is_pair (arg)) 5478 if (!tst_is_list (SCHEME_A_ arg))
5607 break; 5479 break;
5608 } 5480 }
5609 else 5481 else
5610 { 5482 {
5611 if (!tests[j].fct (arg)) 5483 if (!tests[j - 1].fct (arg))
5612 break; 5484 break;
5613 } 5485 }
5614 5486
5615 if (t[1] != 0) /* last test is replicated as necessary */ 5487 if (t < pcd->arg_tests_encoding + sizeof (pcd->arg_tests_encoding) - 1 && t[1]) /* last test is replicated as necessary */
5616 t++; 5488 t++;
5617 5489
5618 arglist = cdr (arglist); 5490 arglist = cdr (arglist);
5619 i++; 5491 i++;
5620 } 5492 }
5621 while (i < n); 5493 while (i < n);
5622 5494
5623 if (i < n) 5495 if (i < n)
5624 { 5496 {
5625 ok = 0;
5626 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", pcd->name, i + 1, tests[j].kind); 5497 snprintf (msg, STRBUFFSIZE, "%s: argument %d must be: %s", opname (SCHEME_V->op), i + 1, tests[j].kind);
5498 xError_1 (SCHEME_A_ msg, 0);
5499 continue;
5627 } 5500 }
5628 } 5501 }
5629 } 5502 }
5630
5631 if (!ok)
5632 {
5633 if (xError_1 (SCHEME_A_ msg, 0) == NIL)
5634 return;
5635
5636 pcd = dispatch_table + SCHEME_V->op;
5637 }
5638 } 5503 }
5639#endif 5504#endif
5640 5505
5641 ok_to_freely_gc (SCHEME_A); 5506 ok_to_freely_gc (SCHEME_A);
5642 5507
5643 if (pcd->func (SCHEME_A_ SCHEME_V->op) == NIL) 5508 static const dispatch_func dispatch_funcs[] = {
5509 opexe_0,
5510 opexe_1,
5511 opexe_2,
5512 opexe_3,
5513 opexe_4,
5514 opexe_5,
5515 opexe_6,
5516 };
5517
5518 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5644 return; 5519 return;
5645 5520
5646 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5521 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5647 { 5522 {
5648 xwrstr ("No memory!\n"); 5523 putstr (SCHEME_A_ "No memory!\n");
5649 return; 5524 return;
5650 } 5525 }
5651 } 5526 }
5652} 5527}
5653 5528
5654/* ========== Initialization of internal keywords ========== */ 5529/* ========== Initialization of internal keywords ========== */
5655 5530
5656static void 5531ecb_cold static void
5657assign_syntax (SCHEME_P_ const char *name) 5532assign_syntax (SCHEME_P_ const char *name)
5658{ 5533{
5659 pointer x = oblist_add_by_name (SCHEME_A_ name); 5534 pointer x = oblist_add_by_name (SCHEME_A_ name);
5660 set_typeflag (x, typeflag (x) | T_SYNTAX); 5535 set_typeflag (x, typeflag (x) | T_SYNTAX);
5661} 5536}
5662 5537
5663static void 5538ecb_cold static void
5664assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5539assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5665{ 5540{
5666 pointer x = mk_symbol (SCHEME_A_ name); 5541 pointer x = mk_symbol (SCHEME_A_ name);
5667 pointer y = mk_proc (SCHEME_A_ op); 5542 pointer y = mk_proc (SCHEME_A_ op);
5668 new_slot_in_env (SCHEME_A_ x, y); 5543 new_slot_in_env (SCHEME_A_ x, y);
… …
5672mk_proc (SCHEME_P_ enum scheme_opcodes op) 5547mk_proc (SCHEME_P_ enum scheme_opcodes op)
5673{ 5548{
5674 pointer y = get_cell (SCHEME_A_ NIL, NIL); 5549 pointer y = get_cell (SCHEME_A_ NIL, NIL);
5675 set_typeflag (y, (T_PROC | T_ATOM)); 5550 set_typeflag (y, (T_PROC | T_ATOM));
5676 ivalue_unchecked (y) = op; 5551 ivalue_unchecked (y) = op;
5677 set_num_integer (y);
5678 return y; 5552 return y;
5679} 5553}
5680 5554
5681/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5555/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5682static int 5556ecb_hot static int
5683syntaxnum (pointer p) 5557syntaxnum (pointer p)
5684{ 5558{
5685 const char *s = strvalue (car (p)); 5559 const char *s = strvalue (p);
5686 5560
5687 switch (strlength (car (p))) 5561 switch (strlength (p))
5688 { 5562 {
5689 case 2: 5563 case 2:
5690 if (s[0] == 'i') 5564 if (s[0] == 'i')
5691 return OP_IF0; /* if */ 5565 return OP_IF0; /* if */
5692 else 5566 else
… …
5706 5580
5707 case 'd': 5581 case 'd':
5708 return OP_COND0; /* cond */ 5582 return OP_COND0; /* cond */
5709 5583
5710 case '*': 5584 case '*':
5711 return OP_LET0AST; /* let* */ 5585 return OP_LET0AST;/* let* */
5712 5586
5713 default: 5587 default:
5714 return OP_SET0; /* set! */ 5588 return OP_SET0; /* set! */
5715 } 5589 }
5716 5590
… …
5738 5612
5739 case 'f': 5613 case 'f':
5740 return OP_DEF0; /* define */ 5614 return OP_DEF0; /* define */
5741 5615
5742 default: 5616 default:
5743 return OP_LET0REC; /* letrec */ 5617 return OP_LET0REC;/* letrec */
5744 } 5618 }
5745 5619
5746 default: 5620 default:
5747 return OP_C0STREAM; /* cons-stream */ 5621 return OP_C0STREAM; /* cons-stream */
5748 } 5622 }
5749} 5623}
5750 5624
5751#if USE_MULTIPLICITY 5625#if USE_MULTIPLICITY
5752scheme * 5626ecb_cold scheme *
5753scheme_init_new () 5627scheme_init_new ()
5754{ 5628{
5755 scheme *sc = malloc (sizeof (scheme)); 5629 scheme *sc = malloc (sizeof (scheme));
5756 5630
5757 if (!scheme_init (SCHEME_A)) 5631 if (!scheme_init (SCHEME_A))
… …
5762 else 5636 else
5763 return sc; 5637 return sc;
5764} 5638}
5765#endif 5639#endif
5766 5640
5767int 5641ecb_cold int
5768scheme_init (SCHEME_P) 5642scheme_init (SCHEME_P)
5769{ 5643{
5770 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5644 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5771 pointer x; 5645 pointer x;
5646
5647 /* this memset is not strictly correct, as we assume (intcache)
5648 * that memset 0 will also set pointers to 0, but memset does
5649 * of course not guarantee that. screw such systems.
5650 */
5651 memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5772 5652
5773 num_set_fixnum (num_zero, 1); 5653 num_set_fixnum (num_zero, 1);
5774 num_set_ivalue (num_zero, 0); 5654 num_set_ivalue (num_zero, 0);
5775 num_set_fixnum (num_one, 1); 5655 num_set_fixnum (num_one, 1);
5776 num_set_ivalue (num_one, 1); 5656 num_set_ivalue (num_one, 1);
… …
5788 SCHEME_V->save_inport = NIL; 5668 SCHEME_V->save_inport = NIL;
5789 SCHEME_V->loadport = NIL; 5669 SCHEME_V->loadport = NIL;
5790 SCHEME_V->nesting = 0; 5670 SCHEME_V->nesting = 0;
5791 SCHEME_V->interactive_repl = 0; 5671 SCHEME_V->interactive_repl = 0;
5792 5672
5793 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 5673 if (!alloc_cellseg (SCHEME_A))
5794 { 5674 {
5795#if USE_ERROR_CHECKING 5675#if USE_ERROR_CHECKING
5796 SCHEME_V->no_memory = 1; 5676 SCHEME_V->no_memory = 1;
5797 return 0; 5677 return 0;
5798#endif 5678#endif
… …
5815 set_cdr (S_T, S_T); 5695 set_cdr (S_T, S_T);
5816 /* init F */ 5696 /* init F */
5817 set_typeflag (S_F, T_ATOM | T_MARK); 5697 set_typeflag (S_F, T_ATOM | T_MARK);
5818 set_car (S_F, S_F); 5698 set_car (S_F, S_F);
5819 set_cdr (S_F, S_F); 5699 set_cdr (S_F, S_F);
5700 /* init EOF_OBJ */
5701 set_typeflag (S_EOF, T_ATOM | T_MARK);
5702 set_car (S_EOF, S_EOF);
5703 set_cdr (S_EOF, S_EOF);
5820 /* init sink */ 5704 /* init sink */
5821 set_typeflag (S_SINK, T_PAIR | T_MARK); 5705 set_typeflag (S_SINK, T_PAIR | T_MARK);
5822 set_car (S_SINK, NIL); 5706 set_car (S_SINK, NIL);
5707
5823 /* init c_nest */ 5708 /* init c_nest */
5824 SCHEME_V->c_nest = NIL; 5709 SCHEME_V->c_nest = NIL;
5825 5710
5826 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 5711 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5827 /* init global_env */ 5712 /* init global_env */
… …
5840 5725
5841 for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i) 5726 for (i = 0; i < sizeof (syntax_names) / sizeof (*syntax_names); ++i)
5842 assign_syntax (SCHEME_A_ syntax_names[i]); 5727 assign_syntax (SCHEME_A_ syntax_names[i]);
5843 } 5728 }
5844 5729
5730 // TODO: should iterate via strlen, to avoid n² complexity
5845 for (i = 0; i < n; i++) 5731 for (i = 0; i < n; i++)
5846 if (dispatch_table[i].name != 0) 5732 if (dispatch_table[i].builtin)
5847 assign_proc (SCHEME_A_ i, dispatch_table[i].name); 5733 assign_proc (SCHEME_A_ i, opname (i));
5848 5734
5849 /* initialization of global pointers to special symbols */ 5735 /* initialization of global pointers to special symbols */
5850 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda"); 5736 SCHEME_V->LAMBDA = mk_symbol (SCHEME_A_ "lambda");
5851 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote"); 5737 SCHEME_V->QUOTE = mk_symbol (SCHEME_A_ "quote");
5852 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote"); 5738 SCHEME_V->QQUOTE = mk_symbol (SCHEME_A_ "quasiquote");
… …
5860 5746
5861 return !SCHEME_V->no_memory; 5747 return !SCHEME_V->no_memory;
5862} 5748}
5863 5749
5864#if USE_PORTS 5750#if USE_PORTS
5865void 5751ecb_cold void
5866scheme_set_input_port_file (SCHEME_P_ int fin) 5752scheme_set_input_port_file (SCHEME_P_ int fin)
5867{ 5753{
5868 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 5754 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5869} 5755}
5870 5756
5871void 5757ecb_cold void
5872scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 5758scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5873{ 5759{
5874 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 5760 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5875} 5761}
5876 5762
5877void 5763ecb_cold void
5878scheme_set_output_port_file (SCHEME_P_ int fout) 5764scheme_set_output_port_file (SCHEME_P_ int fout)
5879{ 5765{
5880 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 5766 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5881} 5767}
5882 5768
5883void 5769ecb_cold void
5884scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 5770scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5885{ 5771{
5886 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 5772 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5887} 5773}
5888#endif 5774#endif
5889 5775
5890void 5776ecb_cold void
5891scheme_set_external_data (SCHEME_P_ void *p) 5777scheme_set_external_data (SCHEME_P_ void *p)
5892{ 5778{
5893 SCHEME_V->ext_data = p; 5779 SCHEME_V->ext_data = p;
5894} 5780}
5895 5781
5896void 5782ecb_cold void
5897scheme_deinit (SCHEME_P) 5783scheme_deinit (SCHEME_P)
5898{ 5784{
5899 int i; 5785 int i;
5900 5786
5901#if SHOW_ERROR_LINE 5787#if SHOW_ERROR_LINE
… …
5943 } 5829 }
5944 } 5830 }
5945#endif 5831#endif
5946} 5832}
5947 5833
5948void 5834ecb_cold void
5949scheme_load_file (SCHEME_P_ int fin) 5835scheme_load_file (SCHEME_P_ int fin)
5950{ 5836{
5951 scheme_load_named_file (SCHEME_A_ fin, 0); 5837 scheme_load_named_file (SCHEME_A_ fin, 0);
5952} 5838}
5953 5839
5954void 5840ecb_cold void
5955scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 5841scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5956{ 5842{
5957 dump_stack_reset (SCHEME_A); 5843 dump_stack_reset (SCHEME_A);
5958 SCHEME_V->envir = SCHEME_V->global_env; 5844 SCHEME_V->envir = SCHEME_V->global_env;
5959 SCHEME_V->file_i = 0; 5845 SCHEME_V->file_i = 0;
… …
5986 5872
5987 if (SCHEME_V->retcode == 0) 5873 if (SCHEME_V->retcode == 0)
5988 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5874 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5989} 5875}
5990 5876
5991void 5877ecb_cold void
5992scheme_load_string (SCHEME_P_ const char *cmd) 5878scheme_load_string (SCHEME_P_ const char *cmd)
5993{ 5879{
5994 dump_stack_reset (SCHEME_A); 5880 dump_stack_reset (SCHEME_A);
5995 SCHEME_V->envir = SCHEME_V->global_env; 5881 SCHEME_V->envir = SCHEME_V->global_env;
5996 SCHEME_V->file_i = 0; 5882 SCHEME_V->file_i = 0;
5997 SCHEME_V->load_stack[0].kind = port_input | port_string; 5883 SCHEME_V->load_stack[0].kind = port_input | port_string;
5998 SCHEME_V->load_stack[0].rep.string.start = (char *) cmd; /* This func respects const */ 5884 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5999 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *) cmd + strlen (cmd); 5885 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
6000 SCHEME_V->load_stack[0].rep.string.curr = (char *) cmd; 5886 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
6001#if USE_PORTS 5887#if USE_PORTS
6002 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 5888 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
6003#endif 5889#endif
6004 SCHEME_V->retcode = 0; 5890 SCHEME_V->retcode = 0;
6005 SCHEME_V->interactive_repl = 0; 5891 SCHEME_V->interactive_repl = 0;
… …
6010 5896
6011 if (SCHEME_V->retcode == 0) 5897 if (SCHEME_V->retcode == 0)
6012 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5898 SCHEME_V->retcode = SCHEME_V->nesting != 0;
6013} 5899}
6014 5900
6015void 5901ecb_cold void
6016scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 5902scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
6017{ 5903{
6018 pointer x; 5904 pointer x;
6019 5905
6020 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 5906 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
6025 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 5911 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
6026} 5912}
6027 5913
6028#if !STANDALONE 5914#if !STANDALONE
6029 5915
6030void 5916ecb_cold void
6031scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 5917scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
6032{ 5918{
6033 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 5919 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
6034} 5920}
6035 5921
6036void 5922ecb_cold void
6037scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 5923scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
6038{ 5924{
6039 int i; 5925 int i;
6040 5926
6041 for (i = 0; i < count; i++) 5927 for (i = 0; i < count; i++)
6042 scheme_register_foreign_func (SCHEME_A_ list + i); 5928 scheme_register_foreign_func (SCHEME_A_ list + i);
6043} 5929}
6044 5930
6045pointer 5931ecb_cold pointer
6046scheme_apply0 (SCHEME_P_ const char *procname) 5932scheme_apply0 (SCHEME_P_ const char *procname)
6047{ 5933{
6048 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 5934 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
6049} 5935}
6050 5936
6051void 5937ecb_cold void
6052save_from_C_call (SCHEME_P) 5938save_from_C_call (SCHEME_P)
6053{ 5939{
6054 pointer saved_data = cons (car (S_SINK), 5940 pointer saved_data = cons (car (S_SINK),
6055 cons (SCHEME_V->envir, 5941 cons (SCHEME_V->envir,
6056 SCHEME_V->dump)); 5942 SCHEME_V->dump));
… …
6060 /* Truncate the dump stack so TS will return here when done, not 5946 /* Truncate the dump stack so TS will return here when done, not
6061 directly resume pre-C-call operations. */ 5947 directly resume pre-C-call operations. */
6062 dump_stack_reset (SCHEME_A); 5948 dump_stack_reset (SCHEME_A);
6063} 5949}
6064 5950
6065void 5951ecb_cold void
6066restore_from_C_call (SCHEME_P) 5952restore_from_C_call (SCHEME_P)
6067{ 5953{
6068 set_car (S_SINK, caar (SCHEME_V->c_nest)); 5954 set_car (S_SINK, caar (SCHEME_V->c_nest));
6069 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 5955 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
6070 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 5956 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
6071 /* Pop */ 5957 /* Pop */
6072 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 5958 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
6073} 5959}
6074 5960
6075/* "func" and "args" are assumed to be already eval'ed. */ 5961/* "func" and "args" are assumed to be already eval'ed. */
6076pointer 5962ecb_cold pointer
6077scheme_call (SCHEME_P_ pointer func, pointer args) 5963scheme_call (SCHEME_P_ pointer func, pointer args)
6078{ 5964{
6079 int old_repl = SCHEME_V->interactive_repl; 5965 int old_repl = SCHEME_V->interactive_repl;
6080 5966
6081 SCHEME_V->interactive_repl = 0; 5967 SCHEME_V->interactive_repl = 0;
… …
6088 SCHEME_V->interactive_repl = old_repl; 5974 SCHEME_V->interactive_repl = old_repl;
6089 restore_from_C_call (SCHEME_A); 5975 restore_from_C_call (SCHEME_A);
6090 return SCHEME_V->value; 5976 return SCHEME_V->value;
6091} 5977}
6092 5978
6093pointer 5979ecb_cold pointer
6094scheme_eval (SCHEME_P_ pointer obj) 5980scheme_eval (SCHEME_P_ pointer obj)
6095{ 5981{
6096 int old_repl = SCHEME_V->interactive_repl; 5982 int old_repl = SCHEME_V->interactive_repl;
6097 5983
6098 SCHEME_V->interactive_repl = 0; 5984 SCHEME_V->interactive_repl = 0;
… …
6110 5996
6111/* ========== Main ========== */ 5997/* ========== Main ========== */
6112 5998
6113#if STANDALONE 5999#if STANDALONE
6114 6000
6115# if defined(__APPLE__) && !defined (OSX) 6001ecb_cold int
6116int
6117main ()
6118{
6119 extern MacTS_main (int argc, char **argv);
6120 char **argv;
6121 int argc = ccommand (&argv);
6122
6123 MacTS_main (argc, argv);
6124 return 0;
6125}
6126
6127int
6128MacTS_main (int argc, char **argv)
6129{
6130# else
6131int
6132main (int argc, char **argv) 6002main (int argc, char **argv)
6133{ 6003{
6134# endif
6135# if USE_MULTIPLICITY 6004# if USE_MULTIPLICITY
6136 scheme ssc; 6005 scheme ssc;
6137 scheme *const SCHEME_V = &ssc; 6006 scheme *const SCHEME_V = &ssc;
6138# else 6007# else
6139# endif 6008# endif
6140 int fin; 6009 int fin;
6141 char *file_name = InitFile; 6010 char *file_name = InitFile;
6142 int retcode; 6011 int retcode;
6143 int isfile = 1; 6012 int isfile = 1;
6013 system ("ps v $PPID");//D
6144 6014
6145 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6015 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6146 { 6016 {
6147 xwrstr ("Usage: tinyscheme -?\n"); 6017 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6148 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6018 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6149 xwrstr ("followed by\n"); 6019 putstr (SCHEME_A_ "followed by\n");
6150 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6020 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6151 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6021 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6152 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6022 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6153 xwrstr ("Use - as filename for stdin.\n"); 6023 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6154 return 1; 6024 return 1;
6155 } 6025 }
6156 6026
6157 if (!scheme_init (SCHEME_A)) 6027 if (!scheme_init (SCHEME_A))
6158 { 6028 {
6159 xwrstr ("Could not initialize!\n"); 6029 putstr (SCHEME_A_ "Could not initialize!\n");
6160 return 2; 6030 return 2;
6161 } 6031 }
6162 6032
6163# if USE_PORTS 6033# if USE_PORTS
6164 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6034 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6209 fin = open (file_name, O_RDONLY); 6079 fin = open (file_name, O_RDONLY);
6210#endif 6080#endif
6211 6081
6212 if (isfile && fin < 0) 6082 if (isfile && fin < 0)
6213 { 6083 {
6214 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6084 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6215 } 6085 }
6216 else 6086 else
6217 { 6087 {
6218 if (isfile) 6088 if (isfile)
6219 scheme_load_named_file (SCHEME_A_ fin, file_name); 6089 scheme_load_named_file (SCHEME_A_ fin, file_name);
… …
6223#if USE_PORTS 6093#if USE_PORTS
6224 if (!isfile || fin != STDIN_FILENO) 6094 if (!isfile || fin != STDIN_FILENO)
6225 { 6095 {
6226 if (SCHEME_V->retcode != 0) 6096 if (SCHEME_V->retcode != 0)
6227 { 6097 {
6228 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6098 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6229 } 6099 }
6230 6100
6231 if (isfile) 6101 if (isfile)
6232 close (fin); 6102 close (fin);
6233 } 6103 }

Diff Legend

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