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

Diff Legend

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