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

Diff Legend

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