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

Diff Legend

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