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.44 by root, Mon Nov 30 06:49:11 2015 UTC vs.
Revision 1.66 by root, Mon Dec 7 18:10:57 2015 UTC

… …
16 * (MINISCM) This is a revised and modified version by Akira KIDA. 16 * (MINISCM) This is a revised and modified version by Akira KIDA.
17 * (MINISCM) current version is 0.85k4 (15 May 1994) 17 * (MINISCM) current version is 0.85k4 (15 May 1994)
18 * 18 *
19 */ 19 */
20 20
21#define EXPERIMENT 1 21#define _POSIX_C_SOURCE 200201
22 22#define _XOPEN_SOURCE 600
23#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ 23#define _GNU_SOURCE 1 /* for malloc mremap */
24#include "malloc.c"
25 24
26#define SCHEME_SOURCE 25#define SCHEME_SOURCE
27#include "scheme-private.h" 26#include "scheme-private.h"
28#ifndef WIN32 27#ifndef WIN32
29# include <unistd.h> 28# include <unistd.h>
30#endif 29#endif
31#if USE_MATH 30#if USE_MATH
32# include <math.h> 31# include <math.h>
33#endif 32#endif
34 33
34#define ECB_NO_THREADS 1
35#include "ecb.h" 35#include "ecb.h"
36 36
37#include <sys/types.h> 37#include <sys/types.h>
38#include <sys/stat.h> 38#include <sys/stat.h>
39#include <fcntl.h> 39#include <fcntl.h>
… …
47#include <string.h> 47#include <string.h>
48 48
49#include <limits.h> 49#include <limits.h>
50#include <inttypes.h> 50#include <inttypes.h>
51#include <float.h> 51#include <float.h>
52//#include <ctype.h> 52
53#if !USE_SYSTEM_MALLOC
54# define PAGE_SIZE 4096 /* does not work on sparc/alpha */
55# include "malloc.c"
56# define malloc(n) tiny_malloc (n)
57# define realloc(p,n) tiny_realloc (p, n)
58# define free(p) tiny_free (p)
59#endif
53 60
54#if '1' != '0' + 1 \ 61#if '1' != '0' + 1 \
55 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \ 62 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
56 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \ 63 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
57 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \ 64 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
… …
79 86
80#define BACKQUOTE '`' 87#define BACKQUOTE '`'
81#define WHITESPACE " \t\r\n\v\f" 88#define WHITESPACE " \t\r\n\v\f"
82#define DELIMITERS "()\";" WHITESPACE 89#define DELIMITERS "()\";" WHITESPACE
83 90
84#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 91#define NIL POINTER (&SCHEME_V->xNIL)
85#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 92#define S_T POINTER (&SCHEME_V->xT)
86#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 93#define S_F POINTER (&SCHEME_V->xF)
87#define S_SINK (&SCHEME_V->xsink) 94#define S_SINK POINTER (&SCHEME_V->xsink)
88#define S_EOF (&SCHEME_V->xEOF_OBJ) 95#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
89 96
90#if !USE_MULTIPLICITY 97#if !USE_MULTIPLICITY
91static scheme sc; 98static scheme sc;
92#endif 99#endif
93 100
94static void 101ecb_cold static void
95xbase (char *s, long n, int base) 102xbase (char *s, long n, int base)
96{ 103{
97 if (n < 0) 104 if (n < 0)
98 { 105 {
99 *s++ = '-'; 106 *s++ = '-';
… …
101 } 108 }
102 109
103 char *p = s; 110 char *p = s;
104 111
105 do { 112 do {
106 *p++ = '0' + n % base; 113 *p++ = "0123456789abcdef"[n % base];
107 n /= base; 114 n /= base;
108 } while (n); 115 } while (n);
109 116
110 *p-- = 0; 117 *p-- = 0;
111 118
… …
114 char x = *s; *s = *p; *p = x; 121 char x = *s; *s = *p; *p = x;
115 --p; ++s; 122 --p; ++s;
116 } 123 }
117} 124}
118 125
119static void 126ecb_cold static void
120xnum (char *s, long n) 127xnum (char *s, long n)
121{ 128{
122 xbase (s, n, 10); 129 xbase (s, n, 10);
123} 130}
124 131
125static void 132ecb_cold static void
126xwrstr (const char *s) 133putnum (SCHEME_P_ long n)
127{
128 write (1, s, strlen (s));
129}
130
131static void
132xwrnum (long n)
133{ 134{
134 char buf[64]; 135 char buf[64];
135 136
136 xnum (buf, n); 137 xnum (buf, n);
137 xwrstr (buf); 138 putstr (SCHEME_A_ buf);
138} 139}
140
141#if USE_CHAR_CLASSIFIERS
142#include <ctype.h>
143#else
139 144
140static char 145static char
141xtoupper (char c) 146xtoupper (char c)
142{ 147{
143 if (c >= 'a' && c <= 'z') 148 if (c >= 'a' && c <= 'z')
… …
163 168
164#define toupper(c) xtoupper (c) 169#define toupper(c) xtoupper (c)
165#define tolower(c) xtolower (c) 170#define tolower(c) xtolower (c)
166#define isdigit(c) xisdigit (c) 171#define isdigit(c) xisdigit (c)
167 172
173#endif
174
168#if USE_IGNORECASE 175#if USE_IGNORECASE
169static const char * 176ecb_cold static const char *
170xstrlwr (char *s) 177xstrlwr (char *s)
171{ 178{
172 const char *p = s; 179 const char *p = s;
173 180
174 while (*s) 181 while (*s)
… …
187# define stricmp(a,b) strcmp (a, b) 194# define stricmp(a,b) strcmp (a, b)
188# define strlwr(s) (s) 195# define strlwr(s) (s)
189#endif 196#endif
190 197
191#ifndef prompt 198#ifndef prompt
192# define prompt "ts> " 199# define prompt "ms> "
193#endif 200#endif
194 201
195#ifndef InitFile 202#ifndef InitFile
196# define InitFile "init.scm" 203# define InitFile "init.scm"
197#endif 204#endif
198 205
199#ifndef FIRST_CELLSEGS
200# define FIRST_CELLSEGS 3
201#endif
202
203enum scheme_types 206enum scheme_types
204{ 207{
205 T_INTEGER, 208 T_INTEGER,
209 T_CHARACTER,
206 T_REAL, 210 T_REAL,
207 T_STRING, 211 T_STRING,
208 T_SYMBOL, 212 T_SYMBOL,
209 T_PROC, 213 T_PROC,
210 T_PAIR, /* also used for free cells */ 214 T_PAIR, /* also used for free cells */
211 T_CLOSURE, 215 T_CLOSURE,
216 T_BYTECODE, // temp
217 T_MACRO,
212 T_CONTINUATION, 218 T_CONTINUATION,
213 T_FOREIGN, 219 T_FOREIGN,
214 T_CHARACTER,
215 T_PORT, 220 T_PORT,
216 T_VECTOR, 221 T_VECTOR,
217 T_MACRO,
218 T_PROMISE, 222 T_PROMISE,
219 T_ENVIRONMENT, 223 T_ENVIRONMENT,
220 /* one more... */ 224 T_SPECIAL, // #t, #f, '(), eof-object
225
221 T_NUM_SYSTEM_TYPES 226 T_NUM_SYSTEM_TYPES
222}; 227};
223 228
224#define T_MASKTYPE 0x000f 229#define T_MASKTYPE 0x001f
225#define T_SYNTAX 0x0010 230#define T_SYNTAX 0x0020
226#define T_IMMUTABLE 0x0020 231#define T_IMMUTABLE 0x0040
227#define T_ATOM 0x0040 /* only for gc */ 232#define T_ATOM 0x0080 /* only for gc */
228#define T_MARK 0x0080 /* only for gc */ 233//#define T_MARK 0x0080 /* only for gc */
229 234
230/* num, for generic arithmetic */ 235/* num, for generic arithmetic */
231struct num 236struct num
232{ 237{
233 IVALUE ivalue; 238 IVALUE ivalue;
… …
258static num num_op (enum num_op op, num a, num b); 263static num num_op (enum num_op op, num a, num b);
259static num num_intdiv (num a, num b); 264static num num_intdiv (num a, num b);
260static num num_rem (num a, num b); 265static num num_rem (num a, num b);
261static num num_mod (num a, num b); 266static num num_mod (num a, num b);
262 267
263#if USE_MATH
264static double round_per_R5RS (double x);
265#endif
266static int is_zero_rvalue (RVALUE x); 268static int is_zero_rvalue (RVALUE x);
267 269
268static num num_zero; 270static num num_zero;
269static num num_one; 271static num num_one;
270 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
271/* macros for cell operations */ 277/* macros for cell operations */
272#define typeflag(p) ((p)->flag + 0) 278#define typeflag(p) (CELL(p)->flag + 0)
273#define set_typeflag(p,v) ((p)->flag = (v)) 279#define set_typeflag(p,v) (CELL(p)->flag = (v))
274#define type(p) (typeflag (p) & T_MASKTYPE) 280#define type(p) (typeflag (p) & T_MASKTYPE)
275 281
276INTERFACE int 282INTERFACE int
277is_string (pointer p) 283is_string (pointer p)
278{ 284{
279 return type (p) == T_STRING; 285 return type (p) == T_STRING;
280} 286}
281 287
282#define strvalue(p) ((p)->object.string.svalue) 288#define strvalue(p) (CELL(p)->object.string.svalue)
283#define strlength(p) ((p)->object.string.length) 289#define strlength(p) (CELL(p)->object.string.length)
284 290
285INTERFACE int 291INTERFACE int
286is_vector (pointer p) 292is_vector (pointer p)
287{ 293{
288 return type (p) == T_VECTOR; 294 return type (p) == T_VECTOR;
289} 295}
290 296
291#define vecvalue(p) ((p)->object.vector.vvalue) 297#define vecvalue(p) (CELL(p)->object.vector.vvalue)
292#define veclength(p) ((p)->object.vector.length) 298#define veclength(p) (CELL(p)->object.vector.length)
293INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); 299INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
294INTERFACE pointer vector_get (pointer vec, uint32_t ielem); 300INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
295INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); 301INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
296 302
297INTERFACE int 303INTERFACE int
… …
323string_value (pointer p) 329string_value (pointer p)
324{ 330{
325 return strvalue (p); 331 return strvalue (p);
326} 332}
327 333
328#define ivalue_unchecked(p) (p)->object.ivalue 334#define ivalue_unchecked(p) CELL(p)->object.ivalue
329#define set_ivalue(p,v) (p)->object.ivalue = (v) 335#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
330 336
331#if USE_REAL 337#if USE_REAL
332#define rvalue_unchecked(p) (p)->object.rvalue 338#define rvalue_unchecked(p) CELL(p)->object.rvalue
333#define set_rvalue(p,v) (p)->object.rvalue = (v) 339#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
334#else 340#else
335#define rvalue_unchecked(p) (p)->object.ivalue 341#define rvalue_unchecked(p) CELL(p)->object.ivalue
336#define set_rvalue(p,v) (p)->object.ivalue = (v) 342#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
337#endif 343#endif
338 344
339INTERFACE long 345INTERFACE long
340charvalue (pointer p) 346charvalue (pointer p)
341{ 347{
342 return ivalue_unchecked (p); 348 return ivalue_unchecked (p);
343} 349}
344 350
351#define port(p) CELL(p)->object.port
352#define set_port(p,v) port(p) = (v)
345INTERFACE int 353INTERFACE int
346is_port (pointer p) 354is_port (pointer p)
347{ 355{
348 return type (p) == T_PORT; 356 return type (p) == T_PORT;
349} 357}
350 358
351INTERFACE int 359INTERFACE int
352is_inport (pointer p) 360is_inport (pointer p)
353{ 361{
354 return is_port (p) && p->object.port->kind & port_input; 362 return is_port (p) && port (p)->kind & port_input;
355} 363}
356 364
357INTERFACE int 365INTERFACE int
358is_outport (pointer p) 366is_outport (pointer p)
359{ 367{
360 return is_port (p) && p->object.port->kind & port_output; 368 return is_port (p) && port (p)->kind & port_output;
361} 369}
362 370
363INTERFACE int 371INTERFACE int
364is_pair (pointer p) 372is_pair (pointer p)
365{ 373{
366 return type (p) == T_PAIR; 374 return type (p) == T_PAIR;
367} 375}
368 376
369#define car(p) ((p)->object.cons.car + 0) 377#define car(p) (POINTER (CELL(p)->object.cons.car))
370#define cdr(p) ((p)->object.cons.cdr + 0) 378#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
371 379
372static pointer caar (pointer p) { return car (car (p)); } 380static pointer caar (pointer p) { return car (car (p)); }
373static pointer cadr (pointer p) { return car (cdr (p)); } 381static pointer cadr (pointer p) { return car (cdr (p)); }
374static pointer cdar (pointer p) { return cdr (car (p)); } 382static pointer cdar (pointer p) { return cdr (car (p)); }
375static pointer cddr (pointer p) { return cdr (cdr (p)); } 383static pointer cddr (pointer p) { return cdr (cdr (p)); }
376 384
377static pointer cadar (pointer p) { return car (cdr (car (p))); } 385static pointer cadar (pointer p) { return car (cdr (car (p))); }
378static pointer caddr (pointer p) { return car (cdr (cdr (p))); } 386static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
379static pointer cdaar (pointer p) { return cdr (car (car (p))); } 387static pointer cdaar (pointer p) { return cdr (car (car (p))); }
380 388
389static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); }
390
381INTERFACE void 391INTERFACE void
382set_car (pointer p, pointer q) 392set_car (pointer p, pointer q)
383{ 393{
384 p->object.cons.car = q; 394 CELL(p)->object.cons.car = CELL (q);
385} 395}
386 396
387INTERFACE void 397INTERFACE void
388set_cdr (pointer p, pointer q) 398set_cdr (pointer p, pointer q)
389{ 399{
390 p->object.cons.cdr = q; 400 CELL(p)->object.cons.cdr = CELL (q);
391} 401}
392 402
393INTERFACE pointer 403INTERFACE pointer
394pair_car (pointer p) 404pair_car (pointer p)
395{ 405{
… …
413{ 423{
414 return strvalue (p); 424 return strvalue (p);
415} 425}
416 426
417#if USE_PLIST 427#if USE_PLIST
428#error plists are broken because symbols are no longer pairs
418#define symprop(p) cdr(p) 429#define symprop(p) cdr(p)
419SCHEME_EXPORT int 430SCHEME_EXPORT int
420hasprop (pointer p) 431hasprop (pointer p)
421{ 432{
422 return typeflag (p) & T_SYMBOL; 433 return typeflag (p) & T_SYMBOL;
… …
500 511
501#define is_atom(p) (typeflag (p) & T_ATOM) 512#define is_atom(p) (typeflag (p) & T_ATOM)
502#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 513#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
503#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) 514#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
504 515
516#if 1
517#define is_mark(p) (CELL(p)->mark)
518#define setmark(p) (CELL(p)->mark = 1)
519#define clrmark(p) (CELL(p)->mark = 0)
520#else
505#define is_mark(p) (typeflag (p) & T_MARK) 521#define is_mark(p) (typeflag (p) & T_MARK)
506#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 522#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
507#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 523#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
524#endif
508 525
509INTERFACE int 526INTERFACE int
510is_immutable (pointer p) 527is_immutable (pointer p)
511{ 528{
512 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 529 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
… …
524 proper list: length 541 proper list: length
525 circular list: -1 542 circular list: -1
526 not even a pair: -2 543 not even a pair: -2
527 dotted list: -2 minus length before dot 544 dotted list: -2 minus length before dot
528*/ 545*/
529INTERFACE int 546ecb_hot INTERFACE int
530list_length (SCHEME_P_ pointer a) 547list_length (SCHEME_P_ pointer a)
531{ 548{
532 int i = 0; 549 int i = 0;
533 pointer slow, fast; 550 pointer slow, fast;
534 551
… …
573{ 590{
574 return list_length (SCHEME_A_ a) >= 0; 591 return list_length (SCHEME_A_ a) >= 0;
575} 592}
576 593
577#if USE_CHAR_CLASSIFIERS 594#if USE_CHAR_CLASSIFIERS
595
578ecb_inline int 596ecb_inline int
579Cisalpha (int c) 597Cisalpha (int c)
580{ 598{
581 return isascii (c) && isalpha (c); 599 return isascii (c) && isalpha (c);
582} 600}
… …
640 "gs", 658 "gs",
641 "rs", 659 "rs",
642 "us" 660 "us"
643}; 661};
644 662
645static int 663ecb_cold static int
646is_ascii_name (const char *name, int *pc) 664is_ascii_name (const char *name, int *pc)
647{ 665{
648 int i; 666 int i;
649 667
650 for (i = 0; i < 32; i++) 668 for (i = 0; i < 32; i++)
… …
669 687
670static int file_push (SCHEME_P_ const char *fname); 688static int file_push (SCHEME_P_ const char *fname);
671static void file_pop (SCHEME_P); 689static void file_pop (SCHEME_P);
672static int file_interactive (SCHEME_P); 690static int file_interactive (SCHEME_P);
673ecb_inline int is_one_of (const char *s, int c); 691ecb_inline int is_one_of (const char *s, int c);
674static int alloc_cellseg (SCHEME_P_ int n); 692static int alloc_cellseg (SCHEME_P);
675ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 693ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
676static void finalize_cell (SCHEME_P_ pointer a); 694static void finalize_cell (SCHEME_P_ pointer a);
677static int count_consecutive_cells (pointer x, int needed);
678static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 695static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
679static pointer mk_number (SCHEME_P_ const num n); 696static pointer mk_number (SCHEME_P_ const num n);
680static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 697static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
681static pointer mk_vector (SCHEME_P_ uint32_t len); 698static pointer mk_vector (SCHEME_P_ uint32_t len);
682static pointer mk_atom (SCHEME_P_ char *q); 699static pointer mk_atom (SCHEME_P_ char *q);
683static pointer mk_sharp_const (SCHEME_P_ char *name); 700static pointer mk_sharp_const (SCHEME_P_ char *name);
684 701
702static pointer mk_port (SCHEME_P_ port *p);
703
685#if USE_PORTS 704#if USE_PORTS
686static pointer mk_port (SCHEME_P_ port *p);
687static pointer port_from_filename (SCHEME_P_ const char *fn, int prop); 705static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
688static pointer port_from_file (SCHEME_P_ int, int prop); 706static pointer port_from_file (SCHEME_P_ int, int prop);
689static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 707static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
690static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop); 708static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop);
691static port *port_rep_from_file (SCHEME_P_ int, int prop); 709static port *port_rep_from_file (SCHEME_P_ int, int prop);
692static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 710static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
693static void port_close (SCHEME_P_ pointer p, int flag); 711static void port_close (SCHEME_P_ pointer p, int flag);
694#endif 712#endif
713
695static void mark (pointer a); 714static void mark (pointer a);
696static void gc (SCHEME_P_ pointer a, pointer b); 715static void gc (SCHEME_P_ pointer a, pointer b);
697static int basic_inchar (port *pt); 716static int basic_inchar (port *pt);
698static int inchar (SCHEME_P); 717static int inchar (SCHEME_P);
699static void backchar (SCHEME_P_ int c); 718static void backchar (SCHEME_P_ int c);
700static char *readstr_upto (SCHEME_P_ int skip, const char *delim); 719static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
701static pointer readstrexp (SCHEME_P_ char delim); 720static pointer readstrexp (SCHEME_P_ char delim);
702ecb_inline int skipspace (SCHEME_P); 721static int skipspace (SCHEME_P);
703static int token (SCHEME_P); 722static int token (SCHEME_P);
704static void printslashstring (SCHEME_P_ char *s, int len); 723static void printslashstring (SCHEME_P_ char *s, int len);
705static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 724static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
706static void printatom (SCHEME_P_ pointer l, int f); 725static void printatom (SCHEME_P_ pointer l, int f);
707static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 726static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
873 } 892 }
874 893
875 return ret; 894 return ret;
876} 895}
877 896
878#if USE_MATH
879
880/* Round to nearest. Round to even if midway */
881static double
882round_per_R5RS (double x)
883{
884 double fl = floor (x);
885 double ce = ceil (x);
886 double dfl = x - fl;
887 double dce = ce - x;
888
889 if (dfl > dce)
890 return ce;
891 else if (dfl < dce)
892 return fl;
893 else
894 {
895 if (fmod (fl, 2) == 0) /* I imagine this holds */
896 return fl;
897 else
898 return ce;
899 }
900}
901#endif
902
903static int 897static int
904is_zero_rvalue (RVALUE x) 898is_zero_rvalue (RVALUE x)
905{ 899{
906 return x == 0; 900 return x == 0;
907#if 0 901#if 0
… …
912#endif 906#endif
913#endif 907#endif
914} 908}
915 909
916/* allocate new cell segment */ 910/* allocate new cell segment */
917static int 911ecb_cold static int
918alloc_cellseg (SCHEME_P_ int n) 912alloc_cellseg (SCHEME_P)
919{ 913{
920 pointer newp; 914 struct cell *newp;
921 pointer last; 915 struct cell *last;
922 pointer p; 916 struct cell *p;
923 char *cp; 917 char *cp;
924 long i; 918 long i;
925 int k; 919 int k;
926 920
927 static int segsize = CELL_SEGSIZE >> 1; 921 static int segsize = CELL_SEGSIZE >> 1;
928 segsize <<= 1; 922 segsize <<= 1;
929 923
930 for (k = 0; k < n; k++)
931 {
932 if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
933 return k;
934
935 cp = malloc (segsize * sizeof (struct cell)); 924 cp = malloc (segsize * sizeof (struct cell));
936 925
937 if (!cp && USE_ERROR_CHECKING) 926 if (!cp && USE_ERROR_CHECKING)
938 return k; 927 return k;
939 928
940 i = ++SCHEME_V->last_cell_seg; 929 i = ++SCHEME_V->last_cell_seg;
941 SCHEME_V->alloc_seg[i] = cp;
942 930
943 newp = (pointer)cp; 931 newp = (struct cell *)cp;
944 SCHEME_V->cell_seg[i] = newp; 932 SCHEME_V->cell_seg[i] = newp;
945 SCHEME_V->cell_segsize[i] = segsize; 933 SCHEME_V->cell_segsize[i] = segsize;
946 SCHEME_V->fcells += segsize; 934 SCHEME_V->fcells += segsize;
947 last = newp + segsize - 1; 935 last = newp + segsize - 1;
948 936
949 for (p = newp; p <= last; p++) 937 for (p = newp; p <= last; p++)
950 { 938 {
939 pointer cp = POINTER (p);
940 clrmark (cp);
951 set_typeflag (p, T_PAIR); 941 set_typeflag (cp, T_PAIR);
952 set_car (p, NIL); 942 set_car (cp, NIL);
953 set_cdr (p, p + 1); 943 set_cdr (cp, POINTER (p + 1));
954 } 944 }
955 945
956 set_cdr (last, SCHEME_V->free_cell); 946 set_cdr (POINTER (last), SCHEME_V->free_cell);
957 SCHEME_V->free_cell = newp; 947 SCHEME_V->free_cell = POINTER (newp);
958 }
959 948
960 return n; 949 return 1;
961} 950}
962 951
963/* get new cell. parameter a, b is marked by gc. */ 952/* get new cell. parameter a, b is marked by gc. */
964ecb_inline pointer 953ecb_inline pointer
965get_cell_x (SCHEME_P_ pointer a, pointer b) 954get_cell_x (SCHEME_P_ pointer a, pointer b)
… …
969 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 958 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
970 return S_SINK; 959 return S_SINK;
971 960
972 if (SCHEME_V->free_cell == NIL) 961 if (SCHEME_V->free_cell == NIL)
973 { 962 {
974 const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; 963 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
975 964
976 gc (SCHEME_A_ a, b); 965 gc (SCHEME_A_ a, b);
977 966
978 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 967 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
979 { 968 {
980 /* if only a few recovered, get more to avoid fruitless gc's */ 969 /* if only a few recovered, get more to avoid fruitless gc's */
981 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 970 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
982 { 971 {
983#if USE_ERROR_CHECKING 972#if USE_ERROR_CHECKING
984 SCHEME_V->no_memory = 1; 973 SCHEME_V->no_memory = 1;
985 return S_SINK; 974 return S_SINK;
986#endif 975#endif
… …
998 } 987 }
999} 988}
1000 989
1001/* To retain recent allocs before interpreter knows about them - 990/* To retain recent allocs before interpreter knows about them -
1002 Tehom */ 991 Tehom */
1003 992ecb_hot static void
1004static void
1005push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 993push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1006{ 994{
1007 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 995 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1008 996
1009 set_typeflag (holder, T_PAIR); 997 set_typeflag (holder, T_PAIR);
… …
1011 set_car (holder, recent); 999 set_car (holder, recent);
1012 set_cdr (holder, car (S_SINK)); 1000 set_cdr (holder, car (S_SINK));
1013 set_car (S_SINK, holder); 1001 set_car (S_SINK, holder);
1014} 1002}
1015 1003
1016static pointer 1004ecb_hot static pointer
1017get_cell (SCHEME_P_ pointer a, pointer b) 1005get_cell (SCHEME_P_ pointer a, pointer b)
1018{ 1006{
1019 pointer cell = get_cell_x (SCHEME_A_ a, b); 1007 pointer cell = get_cell_x (SCHEME_A_ a, b);
1020 1008
1021 /* For right now, include "a" and "b" in "cell" so that gc doesn't 1009 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1030} 1018}
1031 1019
1032static pointer 1020static pointer
1033get_vector_object (SCHEME_P_ uint32_t len, pointer init) 1021get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1034{ 1022{
1035 pointer v = get_cell_x (SCHEME_A_ 0, 0); 1023 pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1036 pointer *e = malloc (len * sizeof (pointer)); 1024 pointer *e = malloc (len * sizeof (pointer));
1037 1025
1038 if (!e && USE_ERROR_CHECKING) 1026 if (!e && USE_ERROR_CHECKING)
1039 return S_SINK; 1027 return S_SINK;
1040 1028
1041 /* Record it as a vector so that gc understands it. */ 1029 /* Record it as a vector so that gc understands it. */
1042 set_typeflag (v, T_VECTOR | T_ATOM); 1030 set_typeflag (v, T_VECTOR | T_ATOM);
1043 1031
1044 v->object.vector.vvalue = e; 1032 CELL(v)->object.vector.vvalue = e;
1045 v->object.vector.length = len; 1033 CELL(v)->object.vector.length = len;
1046 fill_vector (v, 0, init); 1034 fill_vector (v, 0, init);
1047 push_recent_alloc (SCHEME_A_ v, NIL); 1035 push_recent_alloc (SCHEME_A_ v, NIL);
1048 1036
1049 return v; 1037 return v;
1050} 1038}
… …
1059static void 1047static void
1060check_cell_alloced (pointer p, int expect_alloced) 1048check_cell_alloced (pointer p, int expect_alloced)
1061{ 1049{
1062 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ 1050 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1063 if (typeflag (p) & !expect_alloced) 1051 if (typeflag (p) & !expect_alloced)
1064 xwrstr ("Cell is already allocated!\n"); 1052 putstr (SCHEME_A_ "Cell is already allocated!\n");
1065 1053
1066 if (!(typeflag (p)) & expect_alloced) 1054 if (!(typeflag (p)) & expect_alloced)
1067 xwrstr ("Cell is not allocated!\n"); 1055 putstr (SCHEME_A_ "Cell is not allocated!\n");
1068} 1056}
1069 1057
1070static void 1058static void
1071check_range_alloced (pointer p, int n, int expect_alloced) 1059check_range_alloced (pointer p, int n, int expect_alloced)
1072{ 1060{
… …
1078#endif 1066#endif
1079 1067
1080/* Medium level cell allocation */ 1068/* Medium level cell allocation */
1081 1069
1082/* get new cons cell */ 1070/* get new cons cell */
1083pointer 1071ecb_hot static pointer
1084xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1072xcons (SCHEME_P_ pointer a, pointer b)
1085{ 1073{
1086 pointer x = get_cell (SCHEME_A_ a, b); 1074 pointer x = get_cell (SCHEME_A_ a, b);
1087 1075
1088 set_typeflag (x, T_PAIR); 1076 set_typeflag (x, T_PAIR);
1089
1090 if (immutable)
1091 setimmutable (x);
1092 1077
1093 set_car (x, a); 1078 set_car (x, a);
1094 set_cdr (x, b); 1079 set_cdr (x, b);
1095 1080
1096 return x; 1081 return x;
1097} 1082}
1098 1083
1099static pointer 1084ecb_hot static pointer
1085ximmutable_cons (SCHEME_P_ pointer a, pointer b)
1086{
1087 pointer x = xcons (SCHEME_A_ a, b);
1088 setimmutable (x);
1089 return x;
1090}
1091
1092#define cons(a,b) xcons (SCHEME_A_ a, b)
1093#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1094
1095ecb_cold static pointer
1100generate_symbol (SCHEME_P_ const char *name) 1096generate_symbol (SCHEME_P_ const char *name)
1101{ 1097{
1102 pointer x = mk_string (SCHEME_A_ name); 1098 pointer x = mk_string (SCHEME_A_ name);
1103 setimmutable (x); 1099 setimmutable (x);
1104 set_typeflag (x, T_SYMBOL | T_ATOM); 1100 set_typeflag (x, T_SYMBOL | T_ATOM);
… …
1110#ifndef USE_OBJECT_LIST 1106#ifndef USE_OBJECT_LIST
1111 1107
1112static int 1108static int
1113hash_fn (const char *key, int table_size) 1109hash_fn (const char *key, int table_size)
1114{ 1110{
1115 const unsigned char *p = key; 1111 const unsigned char *p = (unsigned char *)key;
1116 uint32_t hash = 2166136261; 1112 uint32_t hash = 2166136261U;
1117 1113
1118 while (*p) 1114 while (*p)
1119 hash = (hash ^ *p++) * 16777619; 1115 hash = (hash ^ *p++) * 16777619;
1120 1116
1121 return hash % table_size; 1117 return hash % table_size;
1122} 1118}
1123 1119
1124static pointer 1120ecb_cold static pointer
1125oblist_initial_value (SCHEME_P) 1121oblist_initial_value (SCHEME_P)
1126{ 1122{
1127 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1123 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1128} 1124}
1129 1125
1130/* returns the new symbol */ 1126/* returns the new symbol */
1131static pointer 1127ecb_cold static pointer
1132oblist_add_by_name (SCHEME_P_ const char *name) 1128oblist_add_by_name (SCHEME_P_ const char *name)
1133{ 1129{
1134 pointer x = generate_symbol (SCHEME_A_ name); 1130 pointer x = generate_symbol (SCHEME_A_ name);
1135 int location = hash_fn (name, veclength (SCHEME_V->oblist)); 1131 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1136 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); 1132 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1137 return x; 1133 return x;
1138} 1134}
1139 1135
1140ecb_inline pointer 1136ecb_cold static pointer
1141oblist_find_by_name (SCHEME_P_ const char *name) 1137oblist_find_by_name (SCHEME_P_ const char *name)
1142{ 1138{
1143 int location; 1139 int location;
1144 pointer x; 1140 pointer x;
1145 char *s; 1141 char *s;
… …
1156 } 1152 }
1157 1153
1158 return NIL; 1154 return NIL;
1159} 1155}
1160 1156
1161static pointer 1157ecb_cold static pointer
1162oblist_all_symbols (SCHEME_P) 1158oblist_all_symbols (SCHEME_P)
1163{ 1159{
1164 int i; 1160 int i;
1165 pointer x; 1161 pointer x;
1166 pointer ob_list = NIL; 1162 pointer ob_list = NIL;
… …
1172 return ob_list; 1168 return ob_list;
1173} 1169}
1174 1170
1175#else 1171#else
1176 1172
1177static pointer 1173ecb_cold static pointer
1178oblist_initial_value (SCHEME_P) 1174oblist_initial_value (SCHEME_P)
1179{ 1175{
1180 return NIL; 1176 return NIL;
1181} 1177}
1182 1178
1183ecb_inline pointer 1179ecb_cold static pointer
1184oblist_find_by_name (SCHEME_P_ const char *name) 1180oblist_find_by_name (SCHEME_P_ const char *name)
1185{ 1181{
1186 pointer x; 1182 pointer x;
1187 char *s; 1183 char *s;
1188 1184
… …
1197 1193
1198 return NIL; 1194 return NIL;
1199} 1195}
1200 1196
1201/* returns the new symbol */ 1197/* returns the new symbol */
1202static pointer 1198ecb_cold static pointer
1203oblist_add_by_name (SCHEME_P_ const char *name) 1199oblist_add_by_name (SCHEME_P_ const char *name)
1204{ 1200{
1205 pointer x = mk_string (SCHEME_A_ name); 1201 pointer x = generate_symbol (SCHEME_A_ name);
1206 set_typeflag (x, T_SYMBOL);
1207 setimmutable (x);
1208 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1202 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1209 return x; 1203 return x;
1210} 1204}
1211 1205
1212static pointer 1206ecb_cold static pointer
1213oblist_all_symbols (SCHEME_P) 1207oblist_all_symbols (SCHEME_P)
1214{ 1208{
1215 return SCHEME_V->oblist; 1209 return SCHEME_V->oblist;
1216} 1210}
1217 1211
1218#endif 1212#endif
1219 1213
1220#if USE_PORTS
1221static pointer 1214ecb_cold static pointer
1222mk_port (SCHEME_P_ port *p) 1215mk_port (SCHEME_P_ port *p)
1223{ 1216{
1224 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1217 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1225 1218
1226 set_typeflag (x, T_PORT | T_ATOM); 1219 set_typeflag (x, T_PORT | T_ATOM);
1227 x->object.port = p; 1220 set_port (x, p);
1228 1221
1229 return x; 1222 return x;
1230} 1223}
1231#endif
1232 1224
1233pointer 1225ecb_cold pointer
1234mk_foreign_func (SCHEME_P_ foreign_func f) 1226mk_foreign_func (SCHEME_P_ foreign_func f)
1235{ 1227{
1236 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1228 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1237 1229
1238 set_typeflag (x, (T_FOREIGN | T_ATOM)); 1230 set_typeflag (x, T_FOREIGN | T_ATOM);
1239 x->object.ff = f; 1231 CELL(x)->object.ff = f;
1240 1232
1241 return x; 1233 return x;
1242} 1234}
1243 1235
1244INTERFACE pointer 1236INTERFACE pointer
1245mk_character (SCHEME_P_ int c) 1237mk_character (SCHEME_P_ int c)
1246{ 1238{
1247 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1239 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1248 1240
1249 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1241 set_typeflag (x, T_CHARACTER | T_ATOM);
1250 set_ivalue (x, c & 0xff); 1242 set_ivalue (x, c & 0xff);
1251 1243
1252 return x; 1244 return x;
1253} 1245}
1254 1246
1255/* get number atom (integer) */ 1247/* get number atom (integer) */
1256INTERFACE pointer 1248INTERFACE pointer
1257mk_integer (SCHEME_P_ long n) 1249mk_integer (SCHEME_P_ long n)
1258{ 1250{
1251 pointer p = 0;
1252 pointer *pp = &p;
1253
1254#if USE_INTCACHE
1255 if (n >= INTCACHE_MIN && n <= INTCACHE_MAX)
1256 pp = &SCHEME_V->intcache[n - INTCACHE_MIN];
1257#endif
1258
1259 if (!*pp)
1260 {
1259 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1261 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1260 1262
1261 set_typeflag (x, (T_INTEGER | T_ATOM)); 1263 set_typeflag (x, T_INTEGER | T_ATOM);
1264 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
1262 set_ivalue (x, n); 1265 set_ivalue (x, n);
1263 1266
1267 *pp = x;
1268 }
1269
1264 return x; 1270 return *pp;
1265} 1271}
1266 1272
1267INTERFACE pointer 1273INTERFACE pointer
1268mk_real (SCHEME_P_ RVALUE n) 1274mk_real (SCHEME_P_ RVALUE n)
1269{ 1275{
1270#if USE_REAL 1276#if USE_REAL
1271 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1277 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1272 1278
1273 set_typeflag (x, (T_REAL | T_ATOM)); 1279 set_typeflag (x, T_REAL | T_ATOM);
1274 set_rvalue (x, n); 1280 set_rvalue (x, n);
1275 1281
1276 return x; 1282 return x;
1277#else 1283#else
1278 return mk_integer (SCHEME_A_ n); 1284 return mk_integer (SCHEME_A_ n);
… …
1389 x = oblist_add_by_name (SCHEME_A_ name); 1395 x = oblist_add_by_name (SCHEME_A_ name);
1390 1396
1391 return x; 1397 return x;
1392} 1398}
1393 1399
1394INTERFACE pointer 1400ecb_cold INTERFACE pointer
1395gensym (SCHEME_P) 1401gensym (SCHEME_P)
1396{ 1402{
1397 pointer x; 1403 pointer x;
1398 char name[40] = "gensym-"; 1404 char name[40] = "gensym-";
1399 xnum (name + 7, ++SCHEME_V->gensym_cnt); 1405 xnum (name + 7, ++SCHEME_V->gensym_cnt);
… …
1406{ 1412{
1407 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; 1413 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1408} 1414}
1409 1415
1410/* make symbol or number atom from string */ 1416/* make symbol or number atom from string */
1411static pointer 1417ecb_cold static pointer
1412mk_atom (SCHEME_P_ char *q) 1418mk_atom (SCHEME_P_ char *q)
1413{ 1419{
1414 char c, *p; 1420 char c, *p;
1415 int has_dec_point = 0; 1421 int has_dec_point = 0;
1416 int has_fp_exp = 0; 1422 int has_fp_exp = 0;
… …
1487 1493
1488 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1494 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1489} 1495}
1490 1496
1491/* make constant */ 1497/* make constant */
1492static pointer 1498ecb_cold static pointer
1493mk_sharp_const (SCHEME_P_ char *name) 1499mk_sharp_const (SCHEME_P_ char *name)
1494{ 1500{
1495 if (!strcmp (name, "t")) 1501 if (!strcmp (name, "t"))
1496 return S_T; 1502 return S_T;
1497 else if (!strcmp (name, "f")) 1503 else if (!strcmp (name, "f"))
1498 return S_F; 1504 return S_F;
1499 else if (*name == '\\') /* #\w (character) */ 1505 else if (*name == '\\') /* #\w (character) */
1500 { 1506 {
1501 int c; 1507 int c;
1502 1508
1509 // TODO: optimise
1503 if (stricmp (name + 1, "space") == 0) 1510 if (stricmp (name + 1, "space") == 0)
1504 c = ' '; 1511 c = ' ';
1505 else if (stricmp (name + 1, "newline") == 0) 1512 else if (stricmp (name + 1, "newline") == 0)
1506 c = '\n'; 1513 c = '\n';
1507 else if (stricmp (name + 1, "return") == 0) 1514 else if (stricmp (name + 1, "return") == 0)
1508 c = '\r'; 1515 c = '\r';
1509 else if (stricmp (name + 1, "tab") == 0) 1516 else if (stricmp (name + 1, "tab") == 0)
1510 c = '\t'; 1517 c = '\t';
1518 else if (stricmp (name + 1, "alarm") == 0)
1519 c = 0x07;
1520 else if (stricmp (name + 1, "backspace") == 0)
1521 c = 0x08;
1522 else if (stricmp (name + 1, "escape") == 0)
1523 c = 0x1b;
1524 else if (stricmp (name + 1, "delete") == 0)
1525 c = 0x7f;
1526 else if (stricmp (name + 1, "null") == 0)
1527 c = 0;
1511 else if (name[1] == 'x' && name[2] != 0) 1528 else if (name[1] == 'x' && name[2] != 0)
1512 { 1529 {
1513 long c1 = strtol (name + 2, 0, 16); 1530 long c1 = strtol (name + 2, 0, 16);
1514 1531
1515 if (0 <= c1 && c1 <= UCHAR_MAX) 1532 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1540 return NIL; 1557 return NIL;
1541 } 1558 }
1542} 1559}
1543 1560
1544/* ========== garbage collector ========== */ 1561/* ========== garbage collector ========== */
1562
1563static void
1564finalize_cell (SCHEME_P_ pointer a)
1565{
1566 /* TODO, fast bitmap check? */
1567 if (is_string (a) || is_symbol (a))
1568 free (strvalue (a));
1569 else if (is_vector (a))
1570 free (vecvalue (a));
1571#if USE_PORTS
1572 else if (is_port (a))
1573 {
1574 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1575 port_close (SCHEME_A_ a, port_input | port_output);
1576
1577 free (port (a));
1578 }
1579#endif
1580}
1545 1581
1546/*-- 1582/*--
1547 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1583 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1548 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1584 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1549 * for marking. 1585 * for marking.
1550 * 1586 *
1551 * The exception is vectors - vectors are currently marked recursively, 1587 * The exception is vectors - vectors are currently marked recursively,
1552 * which is inherited form tinyscheme and could be fixed by having another 1588 * which is inherited form tinyscheme and could be fixed by having another
1553 * word of context in the vector 1589 * word of context in the vector
1554 */ 1590 */
1555static void 1591ecb_hot static void
1556mark (pointer a) 1592mark (pointer a)
1557{ 1593{
1558 pointer t, q, p; 1594 pointer t, q, p;
1559 1595
1560 t = 0; 1596 t = 0;
… …
1617 p = q; 1653 p = q;
1618 goto E6; 1654 goto E6;
1619 } 1655 }
1620} 1656}
1621 1657
1658ecb_hot static void
1659gc_free (SCHEME_P)
1660{
1661 int i;
1662 uint32_t total = 0;
1663
1664 /* Here we scan the cells to build the free-list. */
1665 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1666 {
1667 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1668 struct cell *p;
1669 total += SCHEME_V->cell_segsize [i];
1670
1671 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1672 {
1673 pointer c = POINTER (p);
1674
1675 if (is_mark (c))
1676 clrmark (c);
1677 else
1678 {
1679 /* reclaim cell */
1680 if (typeflag (c) != T_PAIR)
1681 {
1682 finalize_cell (SCHEME_A_ c);
1683 set_typeflag (c, T_PAIR);
1684 set_car (c, NIL);
1685 }
1686
1687 ++SCHEME_V->fcells;
1688 set_cdr (c, SCHEME_V->free_cell);
1689 SCHEME_V->free_cell = c;
1690 }
1691 }
1692 }
1693
1694 if (SCHEME_V->gc_verbose)
1695 {
1696 putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n");
1697 }
1698}
1699
1622/* garbage collection. parameter a, b is marked. */ 1700/* garbage collection. parameter a, b is marked. */
1623static void 1701ecb_cold static void
1624gc (SCHEME_P_ pointer a, pointer b) 1702gc (SCHEME_P_ pointer a, pointer b)
1625{ 1703{
1626 pointer p;
1627 int i; 1704 int i;
1628 1705
1629 if (SCHEME_V->gc_verbose) 1706 if (SCHEME_V->gc_verbose)
1630 putstr (SCHEME_A_ "gc..."); 1707 putstr (SCHEME_A_ "gc...");
1631 1708
… …
1647 /* Mark recent objects the interpreter doesn't know about yet. */ 1724 /* Mark recent objects the interpreter doesn't know about yet. */
1648 mark (car (S_SINK)); 1725 mark (car (S_SINK));
1649 /* Mark any older stuff above nested C calls */ 1726 /* Mark any older stuff above nested C calls */
1650 mark (SCHEME_V->c_nest); 1727 mark (SCHEME_V->c_nest);
1651 1728
1729#if USE_INTCACHE
1730 /* mark intcache */
1731 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1732 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1733 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1734#endif
1735
1652 /* mark variables a, b */ 1736 /* mark variables a, b */
1653 mark (a); 1737 mark (a);
1654 mark (b); 1738 mark (b);
1655 1739
1656 /* garbage collect */ 1740 /* garbage collect */
1657 clrmark (NIL); 1741 clrmark (NIL);
1658 SCHEME_V->fcells = 0; 1742 SCHEME_V->fcells = 0;
1659 SCHEME_V->free_cell = NIL; 1743 SCHEME_V->free_cell = NIL;
1660 1744
1661 uint32_t total = 0;
1662
1663 /* Here we scan the cells to build the free-list. */
1664 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1665 {
1666 pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1667 total += SCHEME_V->cell_segsize [i];
1668
1669 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1670 {
1671 if (is_mark (p))
1672 clrmark (p);
1673 else
1674 {
1675 /* reclaim cell */
1676 if (typeflag (p) != T_PAIR)
1677 {
1678 finalize_cell (SCHEME_A_ p);
1679 set_typeflag (p, T_PAIR);
1680 set_car (p, NIL);
1681 }
1682
1683 ++SCHEME_V->fcells;
1684 set_cdr (p, SCHEME_V->free_cell);
1685 SCHEME_V->free_cell = p;
1686 }
1687 }
1688 }
1689
1690 if (SCHEME_V->gc_verbose) 1745 if (SCHEME_V->gc_verbose)
1691 { 1746 putstr (SCHEME_A_ "freeing...");
1692 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n");
1693 }
1694}
1695 1747
1696static void 1748 gc_free (SCHEME_A);
1697finalize_cell (SCHEME_P_ pointer a)
1698{
1699 /* TODO, fast bitmap check? */
1700 if (is_string (a) || is_symbol (a))
1701 free (strvalue (a));
1702 else if (is_vector (a))
1703 free (vecvalue (a));
1704#if USE_PORTS
1705 else if (is_port (a))
1706 {
1707 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1708 port_close (SCHEME_A_ a, port_input | port_output);
1709
1710 free (a->object.port);
1711 }
1712#endif
1713} 1749}
1714 1750
1715/* ========== Routines for Reading ========== */ 1751/* ========== Routines for Reading ========== */
1716 1752
1717static int 1753ecb_cold static int
1718file_push (SCHEME_P_ const char *fname) 1754file_push (SCHEME_P_ const char *fname)
1719{ 1755{
1720#if USE_PORTS
1721 int fin; 1756 int fin;
1722 1757
1723 if (SCHEME_V->file_i == MAXFIL - 1) 1758 if (SCHEME_V->file_i == MAXFIL - 1)
1724 return 0; 1759 return 0;
1725 1760
… …
1731 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1766 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1732 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1767 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1733 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; 1768 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1734 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; 1769 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1735 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1770 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1736 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1771 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1737 1772
1738#if SHOW_ERROR_LINE 1773#if SHOW_ERROR_LINE
1739 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1774 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1740 1775
1741 if (fname) 1776 if (fname)
1742 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0); 1777 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1743#endif 1778#endif
1744 } 1779 }
1745 1780
1746 return fin >= 0; 1781 return fin >= 0;
1747
1748#else
1749 return 1;
1750#endif
1751} 1782}
1752 1783
1753static void 1784ecb_cold static void
1754file_pop (SCHEME_P) 1785file_pop (SCHEME_P)
1755{ 1786{
1756 if (SCHEME_V->file_i != 0) 1787 if (SCHEME_V->file_i != 0)
1757 { 1788 {
1758 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1789 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1759#if USE_PORTS 1790#if USE_PORTS
1760 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1791 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1761#endif 1792#endif
1762 SCHEME_V->file_i--; 1793 SCHEME_V->file_i--;
1763 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1794 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1764 } 1795 }
1765} 1796}
1766 1797
1767static int 1798ecb_cold static int
1768file_interactive (SCHEME_P) 1799file_interactive (SCHEME_P)
1769{ 1800{
1770#if USE_PORTS 1801#if USE_PORTS
1771 return SCHEME_V->file_i == 0 1802 return SCHEME_V->file_i == 0
1772 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1803 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1773 && (SCHEME_V->inport->object.port->kind & port_file); 1804 && (port (SCHEME_V->inport)->kind & port_file);
1774#else 1805#else
1775 return 0; 1806 return 0;
1776#endif 1807#endif
1777} 1808}
1778 1809
1779#if USE_PORTS 1810#if USE_PORTS
1780static port * 1811ecb_cold static port *
1781port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1812port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1782{ 1813{
1783 int fd; 1814 int fd;
1784 int flags; 1815 int flags;
1785 char *rw; 1816 char *rw;
… …
1808# endif 1839# endif
1809 1840
1810 return pt; 1841 return pt;
1811} 1842}
1812 1843
1813static pointer 1844ecb_cold static pointer
1814port_from_filename (SCHEME_P_ const char *fn, int prop) 1845port_from_filename (SCHEME_P_ const char *fn, int prop)
1815{ 1846{
1816 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1847 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1817 1848
1818 if (!pt && USE_ERROR_CHECKING) 1849 if (!pt && USE_ERROR_CHECKING)
1819 return NIL; 1850 return NIL;
1820 1851
1821 return mk_port (SCHEME_A_ pt); 1852 return mk_port (SCHEME_A_ pt);
1822} 1853}
1823 1854
1824static port * 1855ecb_cold static port *
1825port_rep_from_file (SCHEME_P_ int f, int prop) 1856port_rep_from_file (SCHEME_P_ int f, int prop)
1826{ 1857{
1827 port *pt = malloc (sizeof *pt); 1858 port *pt = malloc (sizeof *pt);
1828 1859
1829 if (!pt && USE_ERROR_CHECKING) 1860 if (!pt && USE_ERROR_CHECKING)
… …
1834 pt->rep.stdio.file = f; 1865 pt->rep.stdio.file = f;
1835 pt->rep.stdio.closeit = 0; 1866 pt->rep.stdio.closeit = 0;
1836 return pt; 1867 return pt;
1837} 1868}
1838 1869
1839static pointer 1870ecb_cold static pointer
1840port_from_file (SCHEME_P_ int f, int prop) 1871port_from_file (SCHEME_P_ int f, int prop)
1841{ 1872{
1842 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1873 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1843 1874
1844 if (!pt && USE_ERROR_CHECKING) 1875 if (!pt && USE_ERROR_CHECKING)
1845 return NIL; 1876 return NIL;
1846 1877
1847 return mk_port (SCHEME_A_ pt); 1878 return mk_port (SCHEME_A_ pt);
1848} 1879}
1849 1880
1850static port * 1881ecb_cold static port *
1851port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1882port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1852{ 1883{
1853 port *pt = malloc (sizeof (port)); 1884 port *pt = malloc (sizeof (port));
1854 1885
1855 if (!pt && USE_ERROR_CHECKING) 1886 if (!pt && USE_ERROR_CHECKING)
… …
1861 pt->rep.string.curr = start; 1892 pt->rep.string.curr = start;
1862 pt->rep.string.past_the_end = past_the_end; 1893 pt->rep.string.past_the_end = past_the_end;
1863 return pt; 1894 return pt;
1864} 1895}
1865 1896
1866static pointer 1897ecb_cold static pointer
1867port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1898port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1868{ 1899{
1869 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1900 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1870 1901
1871 if (!pt && USE_ERROR_CHECKING) 1902 if (!pt && USE_ERROR_CHECKING)
… …
1874 return mk_port (SCHEME_A_ pt); 1905 return mk_port (SCHEME_A_ pt);
1875} 1906}
1876 1907
1877# define BLOCK_SIZE 256 1908# define BLOCK_SIZE 256
1878 1909
1879static port * 1910ecb_cold static port *
1880port_rep_from_scratch (SCHEME_P) 1911port_rep_from_scratch (SCHEME_P)
1881{ 1912{
1882 char *start; 1913 char *start;
1883 port *pt = malloc (sizeof (port)); 1914 port *pt = malloc (sizeof (port));
1884 1915
… …
1898 pt->rep.string.curr = start; 1929 pt->rep.string.curr = start;
1899 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1930 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1900 return pt; 1931 return pt;
1901} 1932}
1902 1933
1903static pointer 1934ecb_cold static pointer
1904port_from_scratch (SCHEME_P) 1935port_from_scratch (SCHEME_P)
1905{ 1936{
1906 port *pt = port_rep_from_scratch (SCHEME_A); 1937 port *pt = port_rep_from_scratch (SCHEME_A);
1907 1938
1908 if (!pt && USE_ERROR_CHECKING) 1939 if (!pt && USE_ERROR_CHECKING)
1909 return NIL; 1940 return NIL;
1910 1941
1911 return mk_port (SCHEME_A_ pt); 1942 return mk_port (SCHEME_A_ pt);
1912} 1943}
1913 1944
1914static void 1945ecb_cold static void
1915port_close (SCHEME_P_ pointer p, int flag) 1946port_close (SCHEME_P_ pointer p, int flag)
1916{ 1947{
1917 port *pt = p->object.port; 1948 port *pt = port (p);
1918 1949
1919 pt->kind &= ~flag; 1950 pt->kind &= ~flag;
1920 1951
1921 if ((pt->kind & (port_input | port_output)) == 0) 1952 if ((pt->kind & (port_input | port_output)) == 0)
1922 { 1953 {
… …
1939 } 1970 }
1940} 1971}
1941#endif 1972#endif
1942 1973
1943/* get new character from input file */ 1974/* get new character from input file */
1944static int 1975ecb_cold static int
1945inchar (SCHEME_P) 1976inchar (SCHEME_P)
1946{ 1977{
1947 int c; 1978 int c;
1948 port *pt; 1979 port *pt = port (SCHEME_V->inport);
1949
1950 pt = SCHEME_V->inport->object.port;
1951 1980
1952 if (pt->kind & port_saw_EOF) 1981 if (pt->kind & port_saw_EOF)
1953 return EOF; 1982 return EOF;
1954 1983
1955 c = basic_inchar (pt); 1984 c = basic_inchar (pt);
… …
1965 } 1994 }
1966 1995
1967 return c; 1996 return c;
1968} 1997}
1969 1998
1970static int ungot = -1; 1999ecb_cold static int
1971
1972static int
1973basic_inchar (port *pt) 2000basic_inchar (port *pt)
1974{ 2001{
1975#if USE_PORTS
1976 if (pt->unget != -1) 2002 if (pt->unget != -1)
1977 { 2003 {
1978 int r = pt->unget; 2004 int r = pt->unget;
1979 pt->unget = -1; 2005 pt->unget = -1;
1980 return r; 2006 return r;
1981 } 2007 }
1982 2008
2009#if USE_PORTS
1983 if (pt->kind & port_file) 2010 if (pt->kind & port_file)
1984 { 2011 {
1985 char c; 2012 char c;
1986 2013
1987 if (!read (pt->rep.stdio.file, &c, 1)) 2014 if (!read (pt->rep.stdio.file, &c, 1))
… …
1995 return EOF; 2022 return EOF;
1996 else 2023 else
1997 return *pt->rep.string.curr++; 2024 return *pt->rep.string.curr++;
1998 } 2025 }
1999#else 2026#else
2000 if (ungot == -1)
2001 {
2002 char c; 2027 char c;
2003 if (!read (0, &c, 1)) 2028
2029 if (!read (pt->rep.stdio.file, &c, 1))
2004 return EOF; 2030 return EOF;
2005 2031
2006 ungot = c;
2007 }
2008
2009 {
2010 int r = ungot;
2011 ungot = -1;
2012 return r; 2032 return c;
2013 }
2014#endif 2033#endif
2015} 2034}
2016 2035
2017/* back character to input buffer */ 2036/* back character to input buffer */
2018static void 2037ecb_cold static void
2019backchar (SCHEME_P_ int c) 2038backchar (SCHEME_P_ int c)
2020{ 2039{
2021#if USE_PORTS 2040 port *pt = port (SCHEME_V->inport);
2022 port *pt;
2023 2041
2024 if (c == EOF) 2042 if (c == EOF)
2025 return; 2043 return;
2026 2044
2027 pt = SCHEME_V->inport->object.port;
2028 pt->unget = c; 2045 pt->unget = c;
2029#else
2030 if (c == EOF)
2031 return;
2032
2033 ungot = c;
2034#endif
2035} 2046}
2036 2047
2037#if USE_PORTS 2048#if USE_PORTS
2038static int 2049ecb_cold static int
2039realloc_port_string (SCHEME_P_ port *p) 2050realloc_port_string (SCHEME_P_ port *p)
2040{ 2051{
2041 char *start = p->rep.string.start; 2052 char *start = p->rep.string.start;
2042 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2053 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2043 char *str = malloc (new_size); 2054 char *str = malloc (new_size);
… …
2056 else 2067 else
2057 return 0; 2068 return 0;
2058} 2069}
2059#endif 2070#endif
2060 2071
2061INTERFACE void 2072ecb_cold static void
2062putstr (SCHEME_P_ const char *s) 2073putchars (SCHEME_P_ const char *s, int len)
2063{ 2074{
2075 port *pt = port (SCHEME_V->outport);
2076
2064#if USE_PORTS 2077#if USE_PORTS
2065 port *pt = SCHEME_V->outport->object.port;
2066
2067 if (pt->kind & port_file)
2068 write (pt->rep.stdio.file, s, strlen (s));
2069 else
2070 for (; *s; s++)
2071 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2072 *pt->rep.string.curr++ = *s;
2073 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2074 *pt->rep.string.curr++ = *s;
2075
2076#else
2077 xwrstr (s);
2078#endif
2079}
2080
2081static void
2082putchars (SCHEME_P_ const char *s, int len)
2083{
2084#if USE_PORTS
2085 port *pt = SCHEME_V->outport->object.port;
2086
2087 if (pt->kind & port_file) 2078 if (pt->kind & port_file)
2088 write (pt->rep.stdio.file, s, len); 2079 write (pt->rep.stdio.file, s, len);
2089 else 2080 else
2090 { 2081 {
2091 for (; len; len--) 2082 for (; len; len--)
… …
2096 *pt->rep.string.curr++ = *s++; 2087 *pt->rep.string.curr++ = *s++;
2097 } 2088 }
2098 } 2089 }
2099 2090
2100#else 2091#else
2101 write (1, s, len); 2092 write (1, s, len); // output not initialised
2102#endif 2093#endif
2094}
2095
2096INTERFACE void
2097putstr (SCHEME_P_ const char *s)
2098{
2099 putchars (SCHEME_A_ s, strlen (s));
2103} 2100}
2104 2101
2105INTERFACE void 2102INTERFACE void
2106putcharacter (SCHEME_P_ int c) 2103putcharacter (SCHEME_P_ int c)
2107{ 2104{
2108#if USE_PORTS
2109 port *pt = SCHEME_V->outport->object.port;
2110
2111 if (pt->kind & port_file)
2112 {
2113 char cc = c;
2114 write (pt->rep.stdio.file, &cc, 1);
2115 }
2116 else
2117 {
2118 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2119 *pt->rep.string.curr++ = c;
2120 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2121 *pt->rep.string.curr++ = c;
2122 }
2123
2124#else
2125 char cc = c; 2105 char cc = c;
2126 write (1, &c, 1); 2106
2127#endif 2107 putchars (SCHEME_A_ &cc, 1);
2128} 2108}
2129 2109
2130/* read characters up to delimiter, but cater to character constants */ 2110/* read characters up to delimiter, but cater to character constants */
2131static char * 2111ecb_cold static char *
2132readstr_upto (SCHEME_P_ int skip, const char *delim) 2112readstr_upto (SCHEME_P_ int skip, const char *delim)
2133{ 2113{
2134 char *p = SCHEME_V->strbuff + skip; 2114 char *p = SCHEME_V->strbuff + skip;
2135 2115
2136 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2116 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
… …
2145 2125
2146 return SCHEME_V->strbuff; 2126 return SCHEME_V->strbuff;
2147} 2127}
2148 2128
2149/* read string expression "xxx...xxx" */ 2129/* read string expression "xxx...xxx" */
2150static pointer 2130ecb_cold static pointer
2151readstrexp (SCHEME_P_ char delim) 2131readstrexp (SCHEME_P_ char delim)
2152{ 2132{
2153 char *p = SCHEME_V->strbuff; 2133 char *p = SCHEME_V->strbuff;
2154 int c; 2134 int c;
2155 int c1 = 0; 2135 int c1 = 0;
… …
2188 case '7': 2168 case '7':
2189 state = st_oct1; 2169 state = st_oct1;
2190 c1 = c - '0'; 2170 c1 = c - '0';
2191 break; 2171 break;
2192 2172
2173 case 'a': *p++ = '\a'; state = st_ok; break;
2174 case 'n': *p++ = '\n'; state = st_ok; break;
2175 case 'r': *p++ = '\r'; state = st_ok; break;
2176 case 't': *p++ = '\t'; state = st_ok; break;
2177
2178 // this overshoots the minimum requirements of r7rs
2179 case ' ':
2180 case '\t':
2181 case '\r':
2182 case '\n':
2183 skipspace (SCHEME_A);
2184 state = st_ok;
2185 break;
2186
2187 //TODO: x should end in ;, not two-digit hex
2193 case 'x': 2188 case 'x':
2194 case 'X': 2189 case 'X':
2195 state = st_x1; 2190 state = st_x1;
2196 c1 = 0; 2191 c1 = 0;
2197 break;
2198
2199 case 'n':
2200 *p++ = '\n';
2201 state = st_ok;
2202 break;
2203
2204 case 't':
2205 *p++ = '\t';
2206 state = st_ok;
2207 break;
2208
2209 case 'r':
2210 *p++ = '\r';
2211 state = st_ok;
2212 break; 2192 break;
2213 2193
2214 default: 2194 default:
2215 *p++ = c; 2195 *p++ = c;
2216 state = st_ok; 2196 state = st_ok;
… …
2268 } 2248 }
2269 } 2249 }
2270} 2250}
2271 2251
2272/* check c is in chars */ 2252/* check c is in chars */
2273ecb_inline int 2253ecb_cold int
2274is_one_of (const char *s, int c) 2254is_one_of (const char *s, int c)
2275{ 2255{
2276 return c == EOF || !!strchr (s, c); 2256 return c == EOF || !!strchr (s, c);
2277} 2257}
2278 2258
2279/* skip white characters */ 2259/* skip white characters */
2280ecb_inline int 2260ecb_cold int
2281skipspace (SCHEME_P) 2261skipspace (SCHEME_P)
2282{ 2262{
2283 int c, curr_line = 0; 2263 int c, curr_line = 0;
2284 2264
2285 do 2265 do
… …
2305 backchar (SCHEME_A_ c); 2285 backchar (SCHEME_A_ c);
2306 return 1; 2286 return 1;
2307} 2287}
2308 2288
2309/* get token */ 2289/* get token */
2310static int 2290ecb_cold static int
2311token (SCHEME_P) 2291token (SCHEME_P)
2312{ 2292{
2313 int c = skipspace (SCHEME_A); 2293 int c = skipspace (SCHEME_A);
2314 2294
2315 if (c == EOF) 2295 if (c == EOF)
… …
2413} 2393}
2414 2394
2415/* ========== Routines for Printing ========== */ 2395/* ========== Routines for Printing ========== */
2416#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2396#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2417 2397
2418static void 2398ecb_cold static void
2419printslashstring (SCHEME_P_ char *p, int len) 2399printslashstring (SCHEME_P_ char *p, int len)
2420{ 2400{
2421 int i; 2401 int i;
2422 unsigned char *s = (unsigned char *) p; 2402 unsigned char *s = (unsigned char *) p;
2423 2403
… …
2479 2459
2480 putcharacter (SCHEME_A_ '"'); 2460 putcharacter (SCHEME_A_ '"');
2481} 2461}
2482 2462
2483/* print atoms */ 2463/* print atoms */
2484static void 2464ecb_cold static void
2485printatom (SCHEME_P_ pointer l, int f) 2465printatom (SCHEME_P_ pointer l, int f)
2486{ 2466{
2487 char *p; 2467 char *p;
2488 int len; 2468 int len;
2489 2469
2490 atom2str (SCHEME_A_ l, f, &p, &len); 2470 atom2str (SCHEME_A_ l, f, &p, &len);
2491 putchars (SCHEME_A_ p, len); 2471 putchars (SCHEME_A_ p, len);
2492} 2472}
2493 2473
2494/* Uses internal buffer unless string pointer is already available */ 2474/* Uses internal buffer unless string pointer is already available */
2495static void 2475ecb_cold static void
2496atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2476atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2497{ 2477{
2498 char *p; 2478 char *p;
2499 2479
2500 if (l == NIL) 2480 if (l == NIL)
… …
2707 return car (d); 2687 return car (d);
2708 2688
2709 p = cons (car (d), cdr (d)); 2689 p = cons (car (d), cdr (d));
2710 q = p; 2690 q = p;
2711 2691
2712 while (cdr (cdr (p)) != NIL) 2692 while (cddr (p) != NIL)
2713 { 2693 {
2714 d = cons (car (p), cdr (p)); 2694 d = cons (car (p), cdr (p));
2715 2695
2716 if (cdr (cdr (p)) != NIL) 2696 if (cddr (p) != NIL)
2717 p = cdr (d); 2697 p = cdr (d);
2718 } 2698 }
2719 2699
2720 set_cdr (p, car (cdr (p))); 2700 set_cdr (p, cadr (p));
2721 return q; 2701 return q;
2722} 2702}
2723 2703
2724/* reverse list -- produce new list */ 2704/* reverse list -- produce new list */
2725static pointer 2705ecb_hot static pointer
2726reverse (SCHEME_P_ pointer a) 2706reverse (SCHEME_P_ pointer a)
2727{ 2707{
2728 /* a must be checked by gc */ 2708 /* a must be checked by gc */
2729 pointer p = NIL; 2709 pointer p = NIL;
2730 2710
… …
2733 2713
2734 return p; 2714 return p;
2735} 2715}
2736 2716
2737/* reverse list --- in-place */ 2717/* reverse list --- in-place */
2738static pointer 2718ecb_hot static pointer
2739reverse_in_place (SCHEME_P_ pointer term, pointer list) 2719reverse_in_place (SCHEME_P_ pointer term, pointer list)
2740{ 2720{
2741 pointer result = term; 2721 pointer result = term;
2742 pointer p = list; 2722 pointer p = list;
2743 2723
… …
2751 2731
2752 return result; 2732 return result;
2753} 2733}
2754 2734
2755/* append list -- produce new list (in reverse order) */ 2735/* append list -- produce new list (in reverse order) */
2756static pointer 2736ecb_hot static pointer
2757revappend (SCHEME_P_ pointer a, pointer b) 2737revappend (SCHEME_P_ pointer a, pointer b)
2758{ 2738{
2759 pointer result = a; 2739 pointer result = a;
2760 pointer p = b; 2740 pointer p = b;
2761 2741
… …
2770 2750
2771 return S_F; /* signal an error */ 2751 return S_F; /* signal an error */
2772} 2752}
2773 2753
2774/* equivalence of atoms */ 2754/* equivalence of atoms */
2775int 2755ecb_hot int
2776eqv (pointer a, pointer b) 2756eqv (pointer a, pointer b)
2777{ 2757{
2778 if (is_string (a)) 2758 if (is_string (a))
2779 { 2759 {
2780 if (is_string (b)) 2760 if (is_string (b))
… …
2874 } 2854 }
2875 else 2855 else
2876 set_car (env, immutable_cons (slot, car (env))); 2856 set_car (env, immutable_cons (slot, car (env)));
2877} 2857}
2878 2858
2879static pointer 2859ecb_hot static pointer
2880find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2860find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2881{ 2861{
2882 pointer x, y; 2862 pointer x, y;
2883 2863
2884 for (x = env; x != NIL; x = cdr (x)) 2864 for (x = env; x != NIL; x = cdr (x))
… …
2905 return NIL; 2885 return NIL;
2906} 2886}
2907 2887
2908#else /* USE_ALIST_ENV */ 2888#else /* USE_ALIST_ENV */
2909 2889
2910ecb_inline void 2890static void
2911new_frame_in_env (SCHEME_P_ pointer old_env) 2891new_frame_in_env (SCHEME_P_ pointer old_env)
2912{ 2892{
2913 SCHEME_V->envir = immutable_cons (NIL, old_env); 2893 SCHEME_V->envir = immutable_cons (NIL, old_env);
2914 setenvironment (SCHEME_V->envir); 2894 setenvironment (SCHEME_V->envir);
2915} 2895}
2916 2896
2917ecb_inline void 2897static void
2918new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2898new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2919{ 2899{
2920 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2900 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2921} 2901}
2922 2902
2923static pointer 2903ecb_hot static pointer
2924find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2904find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2925{ 2905{
2926 pointer x, y; 2906 pointer x, y;
2927 2907
2928 for (x = env; x != NIL; x = cdr (x)) 2908 for (x = env; x != NIL; x = cdr (x))
… …
2942 return NIL; 2922 return NIL;
2943} 2923}
2944 2924
2945#endif /* USE_ALIST_ENV else */ 2925#endif /* USE_ALIST_ENV else */
2946 2926
2947ecb_inline void 2927static void
2948new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2928new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2949{ 2929{
2950 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 2930 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2951 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2931 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2952} 2932}
2953 2933
2954ecb_inline void 2934static void
2955set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2935set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2956{ 2936{
2957 set_cdr (slot, value); 2937 set_cdr (slot, value);
2958} 2938}
2959 2939
2960ecb_inline pointer 2940static pointer
2961slot_value_in_env (pointer slot) 2941slot_value_in_env (pointer slot)
2962{ 2942{
2963 return cdr (slot); 2943 return cdr (slot);
2964} 2944}
2965 2945
2966/* ========== Evaluation Cycle ========== */ 2946/* ========== Evaluation Cycle ========== */
2967 2947
2968static int 2948ecb_cold static int
2969xError_1 (SCHEME_P_ const char *s, pointer a) 2949xError_1 (SCHEME_P_ const char *s, pointer a)
2970{ 2950{
2971#if USE_ERROR_HOOK
2972 pointer x;
2973 pointer hdl = SCHEME_V->ERROR_HOOK;
2974#endif
2975
2976#if USE_PRINTF 2951#if USE_PRINTF
2977#if SHOW_ERROR_LINE 2952#if SHOW_ERROR_LINE
2978 char sbuf[STRBUFFSIZE]; 2953 char sbuf[STRBUFFSIZE];
2979 2954
2980 /* make sure error is not in REPL */ 2955 /* make sure error is not in REPL */
… …
2995 } 2970 }
2996#endif 2971#endif
2997#endif 2972#endif
2998 2973
2999#if USE_ERROR_HOOK 2974#if USE_ERROR_HOOK
3000 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 2975 pointer x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->ERROR_HOOK, 1);
3001 2976
3002 if (x != NIL) 2977 if (x != NIL)
3003 { 2978 {
3004 pointer code = a 2979 pointer code = a
3005 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL) 2980 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
… …
3049 pointer code; 3024 pointer code;
3050}; 3025};
3051 3026
3052# define STACK_GROWTH 3 3027# define STACK_GROWTH 3
3053 3028
3054static void 3029ecb_hot static void
3055s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3030s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3056{ 3031{
3057 int nframes = (uintptr_t)SCHEME_V->dump; 3032 int nframes = (uintptr_t)SCHEME_V->dump;
3058 struct dump_stack_frame *next_frame; 3033 struct dump_stack_frame *next_frame;
3059 3034
3060 /* enough room for the next frame? */ 3035 /* enough room for the next frame? */
3061 if (nframes >= SCHEME_V->dump_size) 3036 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3062 { 3037 {
3063 SCHEME_V->dump_size += STACK_GROWTH; 3038 SCHEME_V->dump_size += STACK_GROWTH;
3064 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); 3039 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3065 } 3040 }
3066 3041
… …
3072 next_frame->code = code; 3047 next_frame->code = code;
3073 3048
3074 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3049 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3075} 3050}
3076 3051
3077static int 3052static ecb_hot int
3078xs_return (SCHEME_P_ pointer a) 3053xs_return (SCHEME_P_ pointer a)
3079{ 3054{
3080 int nframes = (uintptr_t)SCHEME_V->dump; 3055 int nframes = (uintptr_t)SCHEME_V->dump;
3081 struct dump_stack_frame *frame; 3056 struct dump_stack_frame *frame;
3082 3057
… …
3093 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3068 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3094 3069
3095 return 0; 3070 return 0;
3096} 3071}
3097 3072
3098ecb_inline void 3073ecb_cold void
3099dump_stack_reset (SCHEME_P) 3074dump_stack_reset (SCHEME_P)
3100{ 3075{
3101 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3076 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3102 SCHEME_V->dump = (pointer)+0; 3077 SCHEME_V->dump = (pointer)+0;
3103} 3078}
3104 3079
3105ecb_inline void 3080ecb_cold void
3106dump_stack_initialize (SCHEME_P) 3081dump_stack_initialize (SCHEME_P)
3107{ 3082{
3108 SCHEME_V->dump_size = 0; 3083 SCHEME_V->dump_size = 0;
3109 SCHEME_V->dump_base = 0; 3084 SCHEME_V->dump_base = 0;
3110 dump_stack_reset (SCHEME_A); 3085 dump_stack_reset (SCHEME_A);
3111} 3086}
3112 3087
3113static void 3088ecb_cold static void
3114dump_stack_free (SCHEME_P) 3089dump_stack_free (SCHEME_P)
3115{ 3090{
3116 free (SCHEME_V->dump_base); 3091 free (SCHEME_V->dump_base);
3117 SCHEME_V->dump_base = 0; 3092 SCHEME_V->dump_base = 0;
3118 SCHEME_V->dump = (pointer)0; 3093 SCHEME_V->dump = (pointer)0;
3119 SCHEME_V->dump_size = 0; 3094 SCHEME_V->dump_size = 0;
3120} 3095}
3121 3096
3122static void 3097ecb_cold static void
3123dump_stack_mark (SCHEME_P) 3098dump_stack_mark (SCHEME_P)
3124{ 3099{
3125 int nframes = (uintptr_t)SCHEME_V->dump; 3100 int nframes = (uintptr_t)SCHEME_V->dump;
3126 int i; 3101 int i;
3127 3102
… …
3133 mark (frame->envir); 3108 mark (frame->envir);
3134 mark (frame->code); 3109 mark (frame->code);
3135 } 3110 }
3136} 3111}
3137 3112
3138static pointer 3113ecb_cold static pointer
3139ss_get_cont (SCHEME_P) 3114ss_get_cont (SCHEME_P)
3140{ 3115{
3141 int nframes = (uintptr_t)SCHEME_V->dump; 3116 int nframes = (uintptr_t)SCHEME_V->dump;
3142 int i; 3117 int i;
3143 3118
… …
3155 } 3130 }
3156 3131
3157 return cont; 3132 return cont;
3158} 3133}
3159 3134
3160static void 3135ecb_cold static void
3161ss_set_cont (SCHEME_P_ pointer cont) 3136ss_set_cont (SCHEME_P_ pointer cont)
3162{ 3137{
3163 int i = 0; 3138 int i = 0;
3164 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3139 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3165 3140
… …
3177 SCHEME_V->dump = (pointer)(uintptr_t)i; 3152 SCHEME_V->dump = (pointer)(uintptr_t)i;
3178} 3153}
3179 3154
3180#else 3155#else
3181 3156
3182ecb_inline void 3157ecb_cold void
3183dump_stack_reset (SCHEME_P) 3158dump_stack_reset (SCHEME_P)
3184{ 3159{
3185 SCHEME_V->dump = NIL; 3160 SCHEME_V->dump = NIL;
3186} 3161}
3187 3162
3188ecb_inline void 3163ecb_cold void
3189dump_stack_initialize (SCHEME_P) 3164dump_stack_initialize (SCHEME_P)
3190{ 3165{
3191 dump_stack_reset (SCHEME_A); 3166 dump_stack_reset (SCHEME_A);
3192} 3167}
3193 3168
3194static void 3169ecb_cold static void
3195dump_stack_free (SCHEME_P) 3170dump_stack_free (SCHEME_P)
3196{ 3171{
3197 SCHEME_V->dump = NIL; 3172 SCHEME_V->dump = NIL;
3198} 3173}
3199 3174
3200static int 3175ecb_hot static int
3201xs_return (SCHEME_P_ pointer a) 3176xs_return (SCHEME_P_ pointer a)
3202{ 3177{
3203 pointer dump = SCHEME_V->dump; 3178 pointer dump = SCHEME_V->dump;
3204 3179
3205 SCHEME_V->value = a; 3180 SCHEME_V->value = a;
… …
3215 SCHEME_V->dump = dump; 3190 SCHEME_V->dump = dump;
3216 3191
3217 return 0; 3192 return 0;
3218} 3193}
3219 3194
3220static void 3195ecb_hot static void
3221s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3196s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3222{ 3197{
3223 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3198 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3224 cons (args, 3199 cons (args,
3225 cons (SCHEME_V->envir, 3200 cons (SCHEME_V->envir,
3226 cons (code, 3201 cons (code,
3227 SCHEME_V->dump)))); 3202 SCHEME_V->dump))));
3228} 3203}
3229 3204
3230static void 3205ecb_cold static void
3231dump_stack_mark (SCHEME_P) 3206dump_stack_mark (SCHEME_P)
3232{ 3207{
3233 mark (SCHEME_V->dump); 3208 mark (SCHEME_V->dump);
3234} 3209}
3235 3210
3236static pointer 3211ecb_cold static pointer
3237ss_get_cont (SCHEME_P) 3212ss_get_cont (SCHEME_P)
3238{ 3213{
3239 return SCHEME_V->dump; 3214 return SCHEME_V->dump;
3240} 3215}
3241 3216
3242static void 3217ecb_cold static void
3243ss_set_cont (SCHEME_P_ pointer cont) 3218ss_set_cont (SCHEME_P_ pointer cont)
3244{ 3219{
3245 SCHEME_V->dump = cont; 3220 SCHEME_V->dump = cont;
3246} 3221}
3247 3222
3248#endif 3223#endif
3249 3224
3250#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3225#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3251 3226
3252#if EXPERIMENT 3227#if EXPERIMENT
3228
3253static int 3229static int
3254debug (SCHEME_P_ int indent, pointer x) 3230dtree (SCHEME_P_ int indent, pointer x)
3255{ 3231{
3256 int c; 3232 int c;
3257 3233
3258 if (is_syntax (x)) 3234 if (is_syntax (x))
3259 { 3235 {
… …
3277 printf ("%*sS<%s>\n", indent, "", symname (x)); 3253 printf ("%*sS<%s>\n", indent, "", symname (x));
3278 return 24+8; 3254 return 24+8;
3279 3255
3280 case T_CLOSURE: 3256 case T_CLOSURE:
3281 printf ("%*sS<%s>\n", indent, "", "closure"); 3257 printf ("%*sS<%s>\n", indent, "", "closure");
3282 debug (SCHEME_A_ indent + 3, cdr(x)); 3258 dtree (SCHEME_A_ indent + 3, cdr(x));
3283 return 32 + debug (SCHEME_A_ indent + 3, car (x)); 3259 return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3284 3260
3285 case T_PAIR: 3261 case T_PAIR:
3286 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); 3262 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3287 c = debug (SCHEME_A_ indent + 3, car (x)); 3263 c = dtree (SCHEME_A_ indent + 3, car (x));
3288 c += debug (SCHEME_A_ indent + 3, cdr (x)); 3264 c += dtree (SCHEME_A_ indent + 3, cdr (x));
3289 return c + 1; 3265 return c + 1;
3290 3266
3291 case T_PORT: 3267 case T_PORT:
3292 printf ("%*sS<%s>\n", indent, "", "port"); 3268 printf ("%*sS<%s>\n", indent, "", "port");
3293 return 24+8; 3269 return 24+8;
… …
3296 printf ("%*sS<%s>\n", indent, "", "vector"); 3272 printf ("%*sS<%s>\n", indent, "", "vector");
3297 return 24+8; 3273 return 24+8;
3298 3274
3299 case T_ENVIRONMENT: 3275 case T_ENVIRONMENT:
3300 printf ("%*sS<%s>\n", indent, "", "environment"); 3276 printf ("%*sS<%s>\n", indent, "", "environment");
3301 return 0 + debug (SCHEME_A_ indent + 3, car (x)); 3277 return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3302 3278
3303 default: 3279 default:
3304 printf ("unhandled type %d\n", type (x)); 3280 printf ("unhandled type %d\n", type (x));
3305 break; 3281 break;
3306 } 3282 }
3307} 3283}
3308#endif
3309 3284
3285#define DUMP(t) do { printf ("DUMP %s:%d\n", __FILE__, __LINE__); dtree (SCHEME_A_ 0, (t)); } while (0)
3286
3287typedef void *stream[1];
3288
3289#define stream_init() { 0 }
3290#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
3291#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
3292#define stream_free(s) free (s[0])
3293
3294ecb_cold static void
3295stream_put (stream s, uint8_t byte)
3296{
3297 uint32_t *sp = *s;
3298 uint32_t size = sizeof (uint32_t) * 2;
3299 uint32_t offs = size;
3300
3301 if (ecb_expect_true (sp))
3302 {
3303 offs = sp[0];
3304 size = sp[1];
3305 }
3306
3307 if (ecb_expect_false (offs == size))
3308 {
3309 size *= 2;
3310 sp = realloc (sp, size);
3311 *s = sp;
3312 sp[1] = size;
3313
3314 }
3315
3316 ((uint8_t *)sp)[offs++] = byte;
3317 sp[0] = offs;
3318}
3319
3320ecb_cold static void
3321stream_put_v (stream s, uint32_t v)
3322{
3323 while (v > 0x7f)
3324 {
3325 stream_put (s, v | 0x80);
3326 v >>= 7;
3327 }
3328
3329 stream_put (s, v);
3330}
3331
3332ecb_cold static void
3333stream_put_tv (stream s, int bop, uint32_t v)
3334{
3335 printf ("put tv %d %d\n", bop, v);//D
3336 stream_put (s, bop);
3337 stream_put_v (s, v);
3338}
3339
3340ecb_cold static void
3341stream_put_stream (stream s, stream o)
3342{
3343 uint32_t i;
3344
3345 for (i = 0; i < stream_size (o); ++i)
3346 stream_put (s, stream_data (o)[i]);
3347
3348 stream_free (o);
3349}
3350
3351ecb_cold static uint32_t
3352cell_id (SCHEME_P_ pointer x)
3353{
3354 struct cell *p = CELL (x);
3355 int i;
3356
3357 for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3358 if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3359 return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3360
3361 abort ();
3362}
3363
3364// calculates a (preferably small) integer that makes it possible to find
3365// the symbol again. if pointers were offsets into a memory area... until
3366// then, we return segment number in the low bits, and offset in the high
3367// bits.
3368// also, this function must never return 0.
3369ecb_cold static uint32_t
3370symbol_id (SCHEME_P_ pointer sym)
3371{
3372 return cell_id (SCHEME_A_ sym);
3373}
3374
3375enum byteop
3376{
3377 BOP_NIL,
3378 BOP_INTEGER,
3379 BOP_SYMBOL,
3380 BOP_DATUM,
3381 BOP_LIST_BEG,
3382 BOP_LIST_END,
3383 BOP_IF,
3384 BOP_AND,
3385 BOP_OR,
3386 BOP_CASE,
3387 BOP_COND,
3388 BOP_LET,
3389 BOP_LETAST,
3390 BOP_LETREC,
3391 BOP_DEFINE,
3392 BOP_MACRO,
3393 BOP_SET,
3394 BOP_BEGIN,
3395 BOP_LAMBDA,
3396 BOP_OP,
3397};
3398
3399ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
3400
3401ecb_cold static void
3402compile_list (SCHEME_P_ stream s, pointer x)
3403{
3404 // TODO: improper list
3405
3406 for (; x != NIL; x = cdr (x))
3407 {
3408 stream t = stream_init ();
3409 compile_expr (SCHEME_A_ t, car (x));
3410 stream_put_v (s, stream_size (t));
3411 stream_put_stream (s, t);
3412 }
3413
3414 stream_put_v (s, 0);
3415}
3416
3417static void
3418compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
3419{
3420 stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
3421
3422 stream_put (s, BOP_IF);
3423 compile_expr (SCHEME_A_ s, cond);
3424 stream_put_v (s, stream_size (sift));
3425 stream_put_stream (s, sift);
3426 compile_expr (SCHEME_A_ s, iff);
3427}
3428
3429typedef uint32_t stream_fixup;
3430
3431static stream_fixup
3432stream_put_fixup (stream s)
3433{
3434 stream_put (s, 0);
3435 stream_put (s, 0);
3436
3437 return stream_size (s);
3438}
3439
3440static void
3441stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target)
3442{
3443 target -= fixup;
3444 assert (target < (1 << 14));
3445 stream_data (s)[fixup - 2] = target | 0x80;
3446 stream_data (s)[fixup - 1] = target >> 7;
3447}
3448
3449static void
3450compile_and_or (SCHEME_P_ stream s, int and, pointer x)
3451{
3452 for (; cdr (x) != NIL; x = cdr (x))
3453 {
3454 stream t = stream_init ();
3455 compile_expr (SCHEME_A_ t, car (x));
3456 stream_put_v (s, stream_size (t));
3457 stream_put_stream (s, t);
3458 }
3459
3460 stream_put_v (s, 0);
3461}
3462
3463static void
3464compile_case (SCHEME_P_ stream s, pointer x)
3465{
3466 compile_expr (SCHEME_A_ s, caar (x));
3467
3468 for (;;)
3469 {
3470 x = cdr (x);
3471
3472 if (x == NIL)
3473 break;
3474
3475 compile_expr (SCHEME_A_ s, caar (x));
3476 stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
3477 stream_put_v (s, stream_size (t));
3478 stream_put_stream (s, t);
3479 }
3480
3481 stream_put_v (s, 0);
3482}
3483
3484static void
3485compile_cond (SCHEME_P_ stream s, pointer x)
3486{
3487 for ( ; x != NIL; x = cdr (x))
3488 {
3489 compile_expr (SCHEME_A_ s, caar (x));
3490 stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
3491 stream_put_v (s, stream_size (t));
3492 stream_put_stream (s, t);
3493 }
3494
3495 stream_put_v (s, 0);
3496}
3497
3310static int 3498static pointer
3499lookup (SCHEME_P_ pointer x)
3500{
3501 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, x, 1);
3502
3503 if (x != NIL)
3504 x = slot_value_in_env (x);
3505
3506 return x;
3507}
3508
3509ecb_cold static void
3510compile_expr (SCHEME_P_ stream s, pointer x)
3511{
3512 if (x == NIL)
3513 {
3514 stream_put (s, BOP_NIL);
3515 return;
3516 }
3517
3518 if (is_pair (x))
3519 {
3520 pointer head = car (x);
3521
3522 if (is_syntax (head))
3523 {
3524 x = cdr (x);
3525
3526 switch (syntaxnum (head))
3527 {
3528 case OP_IF0: /* if */
3529 stream_put_v (s, BOP_IF);
3530 compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
3531 break;
3532
3533 case OP_OR0: /* or */
3534 stream_put_v (s, BOP_OR);
3535 compile_and_or (SCHEME_A_ s, 0, x);
3536 break;
3537
3538 case OP_AND0: /* and */
3539 stream_put_v (s, BOP_AND);
3540 compile_and_or (SCHEME_A_ s, 1, x);
3541 break;
3542
3543 case OP_CASE0: /* case */
3544 stream_put_v (s, BOP_CASE);
3545 compile_case (SCHEME_A_ s, x);
3546 break;
3547
3548 case OP_COND0: /* cond */
3549 stream_put_v (s, BOP_COND);
3550 compile_cond (SCHEME_A_ s, x);
3551 break;
3552
3553 case OP_LET0: /* let */
3554 case OP_LET0AST: /* let* */
3555 case OP_LET0REC: /* letrec */
3556 switch (syntaxnum (head))
3557 {
3558 case OP_LET0: stream_put (s, BOP_LET ); break;
3559 case OP_LET0AST: stream_put (s, BOP_LETAST); break;
3560 case OP_LET0REC: stream_put (s, BOP_LETREC); break;
3561 }
3562
3563 {
3564 pointer bindings = car (x);
3565 pointer body = cadr (x);
3566
3567 for (x = bindings; x != NIL; x = cdr (x))
3568 {
3569 pointer init = NIL;
3570 pointer var = car (x);
3571
3572 if (is_pair (var))
3573 {
3574 init = cdr (var);
3575 var = car (var);
3576 }
3577
3578 stream_put_v (s, symbol_id (SCHEME_A_ var));
3579 compile_expr (SCHEME_A_ s, init);
3580 }
3581
3582 stream_put_v (s, 0);
3583 compile_expr (SCHEME_A_ s, body);
3584 }
3585 break;
3586
3587 case OP_DEF0: /* define */
3588 case OP_MACRO0: /* macro */
3589 stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO);
3590 stream_put_v (s, cell_id (SCHEME_A_ car (x)));
3591 compile_expr (SCHEME_A_ s, cadr (x));
3592 break;
3593
3594 case OP_SET0: /* set! */
3595 stream_put (s, BOP_SET);
3596 stream_put_v (s, symbol_id (SCHEME_A_ car (x)));
3597 compile_expr (SCHEME_A_ s, cadr (x));
3598 break;
3599
3600 case OP_BEGIN: /* begin */
3601 stream_put (s, BOP_BEGIN);
3602 compile_list (SCHEME_A_ s, x);
3603 return;
3604
3605 case OP_DELAY: /* delay */
3606 abort ();
3607 break;
3608
3609 case OP_QUOTE: /* quote */
3610 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3611 break;
3612
3613 case OP_LAMBDA: /* lambda */
3614 {
3615 pointer formals = car (x);
3616 pointer body = cadr (x);
3617
3618 stream_put (s, BOP_LAMBDA);
3619
3620 for (; is_pair (formals); formals = cdr (formals))
3621 stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
3622
3623 stream_put_v (s, 0);
3624 stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals));
3625
3626 compile_expr (SCHEME_A_ s, body);
3627 }
3628 break;
3629
3630 case OP_C0STREAM:/* cons-stream */
3631 abort ();
3632 break;
3633 }
3634
3635 return;
3636 }
3637
3638 pointer m = lookup (SCHEME_A_ head);
3639
3640 if (is_macro (m))
3641 {
3642 s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
3643 SCHEME_V->code = m;
3644 SCHEME_V->args = cons (x, NIL);
3645 Eval_Cycle (SCHEME_A_ OP_APPLY);
3646 x = SCHEME_V->value;
3647 compile_expr (SCHEME_A_ s, SCHEME_V->value);
3648 return;
3649 }
3650
3651 stream_put (s, BOP_LIST_BEG);
3652
3653 for (; x != NIL; x = cdr (x))
3654 compile_expr (SCHEME_A_ s, car (x));
3655
3656 stream_put (s, BOP_LIST_END);
3657 return;
3658 }
3659
3660 switch (type (x))
3661 {
3662 case T_INTEGER:
3663 {
3664 IVALUE iv = ivalue_unchecked (x);
3665 iv = iv < 0 ? ((~(uint32_t)iv) << 1) | 1 : (uint32_t)iv << 1;
3666 stream_put_tv (s, BOP_INTEGER, iv);
3667 }
3668 return;
3669
3670 case T_SYMBOL:
3671 if (0)
3672 {
3673 // no can do without more analysis
3674 pointer m = lookup (SCHEME_A_ x);
3675
3676 if (is_proc (m))
3677 {
3678 printf ("compile proc %s %d\n", procname(m), procnum(m));
3679 stream_put_tv (s, BOP_SYMBOL, BOP_OP + procnum (m));
3680 }
3681 else
3682 stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3683 }
3684
3685 stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3686 return;
3687
3688 default:
3689 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3690 break;
3691 }
3692}
3693
3694ecb_cold static int
3695compile_closure (SCHEME_P_ pointer p)
3696{
3697 stream s = stream_init ();
3698
3699 compile_list (SCHEME_A_ s, cdar (p));
3700
3701 FILE *xxd = popen ("xxd", "we");
3702 fwrite (stream_data (s), 1, stream_size (s), xxd);
3703 fclose (xxd);
3704
3705 return stream_size (s);
3706}
3707
3708#endif
3709
3710/* syntax, eval, core, ... */
3711ecb_hot static int
3311opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3712opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3312{ 3713{
3313 pointer args = SCHEME_V->args; 3714 pointer args = SCHEME_V->args;
3314 pointer x, y; 3715 pointer x, y;
3315 3716
3316 switch (op) 3717 switch (op)
3317 { 3718 {
3318#if EXPERIMENT //D 3719#if EXPERIMENT //D
3319 case OP_DEBUG: 3720 case OP_DEBUG:
3320 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3721 {
3722 uint32_t len = compile_closure (SCHEME_A_ car (args));
3723 printf ("len = %d\n", len);
3321 printf ("\n"); 3724 printf ("\n");
3322 s_return (S_T); 3725 s_return (S_T);
3726 }
3727
3728 case OP_DEBUG2:
3729 return -1;
3323#endif 3730#endif
3731
3324 case OP_LOAD: /* load */ 3732 case OP_LOAD: /* load */
3325 if (file_interactive (SCHEME_A)) 3733 if (file_interactive (SCHEME_A))
3326 { 3734 {
3327 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3735 putstr (SCHEME_A_ "Loading ");
3328 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3736 putstr (SCHEME_A_ strvalue (car (args)));
3737 putcharacter (SCHEME_A_ '\n');
3329 } 3738 }
3330 3739
3331 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3740 if (!file_push (SCHEME_A_ strvalue (car (args))))
3332 Error_1 ("unable to open", car (args)); 3741 Error_1 ("unable to open", car (args));
3333 else 3742
3334 {
3335 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3743 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3336 s_goto (OP_T0LVL); 3744 s_goto (OP_T0LVL);
3337 }
3338 3745
3339 case OP_T0LVL: /* top level */ 3746 case OP_T0LVL: /* top level */
3340 3747
3341 /* If we reached the end of file, this loop is done. */ 3748 /* If we reached the end of file, this loop is done. */
3342 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3749 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3343 { 3750 {
3344 if (SCHEME_V->file_i == 0) 3751 if (SCHEME_V->file_i == 0)
3345 { 3752 {
3346 SCHEME_V->args = NIL; 3753 SCHEME_V->args = NIL;
3347 s_goto (OP_QUIT); 3754 s_goto (OP_QUIT);
… …
3358 /* If interactive, be nice to user. */ 3765 /* If interactive, be nice to user. */
3359 if (file_interactive (SCHEME_A)) 3766 if (file_interactive (SCHEME_A))
3360 { 3767 {
3361 SCHEME_V->envir = SCHEME_V->global_env; 3768 SCHEME_V->envir = SCHEME_V->global_env;
3362 dump_stack_reset (SCHEME_A); 3769 dump_stack_reset (SCHEME_A);
3363 putstr (SCHEME_A_ "\n"); 3770 putcharacter (SCHEME_A_ '\n');
3771#if EXPERIMENT
3772 system ("ps v $PPID");
3773#endif
3364 putstr (SCHEME_A_ prompt); 3774 putstr (SCHEME_A_ prompt);
3365 } 3775 }
3366 3776
3367 /* Set up another iteration of REPL */ 3777 /* Set up another iteration of REPL */
3368 SCHEME_V->nesting = 0; 3778 SCHEME_V->nesting = 0;
… …
3403 { 3813 {
3404 SCHEME_V->print_flag = 1; 3814 SCHEME_V->print_flag = 1;
3405 SCHEME_V->args = SCHEME_V->value; 3815 SCHEME_V->args = SCHEME_V->value;
3406 s_goto (OP_P0LIST); 3816 s_goto (OP_P0LIST);
3407 } 3817 }
3408 else 3818
3409 s_return (SCHEME_V->value); 3819 s_return (SCHEME_V->value);
3410 3820
3411 case OP_EVAL: /* main part of evaluation */ 3821 case OP_EVAL: /* main part of evaluation */
3412#if USE_TRACING 3822#if USE_TRACING
3413 if (SCHEME_V->tracing) 3823 if (SCHEME_V->tracing)
3414 { 3824 {
… …
3425#endif 3835#endif
3426 if (is_symbol (SCHEME_V->code)) /* symbol */ 3836 if (is_symbol (SCHEME_V->code)) /* symbol */
3427 { 3837 {
3428 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3838 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3429 3839
3430 if (x != NIL) 3840 if (x == NIL)
3431 s_return (slot_value_in_env (x));
3432 else
3433 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3841 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3842
3843 s_return (slot_value_in_env (x));
3434 } 3844 }
3435 else if (is_pair (SCHEME_V->code)) 3845 else if (is_pair (SCHEME_V->code))
3436 { 3846 {
3437 x = car (SCHEME_V->code); 3847 x = car (SCHEME_V->code);
3438 3848
… …
3447 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3857 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3448 SCHEME_V->code = x; 3858 SCHEME_V->code = x;
3449 s_goto (OP_EVAL); 3859 s_goto (OP_EVAL);
3450 } 3860 }
3451 } 3861 }
3452 else 3862
3453 s_return (SCHEME_V->code); 3863 s_return (SCHEME_V->code);
3454 3864
3455 case OP_E0ARGS: /* eval arguments */ 3865 case OP_E0ARGS: /* eval arguments */
3456 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ 3866 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3457 { 3867 {
3458 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3868 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3459 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3869 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3460 SCHEME_V->code = SCHEME_V->value; 3870 SCHEME_V->code = SCHEME_V->value;
3461 s_goto (OP_APPLY); 3871 s_goto (OP_APPLY);
3462 } 3872 }
3463 else 3873
3464 {
3465 SCHEME_V->code = cdr (SCHEME_V->code); 3874 SCHEME_V->code = cdr (SCHEME_V->code);
3466 s_goto (OP_E1ARGS); 3875 s_goto (OP_E1ARGS);
3467 }
3468 3876
3469 case OP_E1ARGS: /* eval arguments */ 3877 case OP_E1ARGS: /* eval arguments */
3470 args = cons (SCHEME_V->value, args); 3878 args = cons (SCHEME_V->value, args);
3471 3879
3472 if (is_pair (SCHEME_V->code)) /* continue */ 3880 if (is_pair (SCHEME_V->code)) /* continue */
… …
3483 SCHEME_V->args = cdr (args); 3891 SCHEME_V->args = cdr (args);
3484 s_goto (OP_APPLY); 3892 s_goto (OP_APPLY);
3485 } 3893 }
3486 3894
3487#if USE_TRACING 3895#if USE_TRACING
3488
3489 case OP_TRACING: 3896 case OP_TRACING:
3490 { 3897 {
3491 int tr = SCHEME_V->tracing; 3898 int tr = SCHEME_V->tracing;
3492 3899
3493 SCHEME_V->tracing = ivalue_unchecked (car (args)); 3900 SCHEME_V->tracing = ivalue_unchecked (car (args));
3494 s_return (mk_integer (SCHEME_A_ tr)); 3901 s_return (mk_integer (SCHEME_A_ tr));
3495 } 3902 }
3496
3497#endif 3903#endif
3498 3904
3499 case OP_APPLY: /* apply 'code' to 'args' */ 3905 case OP_APPLY: /* apply 'code' to 'args' */
3500#if USE_TRACING 3906#if USE_TRACING
3501 if (SCHEME_V->tracing) 3907 if (SCHEME_V->tracing)
… …
3515 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3921 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3516 else if (is_foreign (SCHEME_V->code)) 3922 else if (is_foreign (SCHEME_V->code))
3517 { 3923 {
3518 /* Keep nested calls from GC'ing the arglist */ 3924 /* Keep nested calls from GC'ing the arglist */
3519 push_recent_alloc (SCHEME_A_ args, NIL); 3925 push_recent_alloc (SCHEME_A_ args, NIL);
3520 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3926 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3521 3927
3522 s_return (x); 3928 s_return (x);
3523 } 3929 }
3524 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3930 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3525 { 3931 {
… …
3555 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3961 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3556 { 3962 {
3557 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3963 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3558 s_return (args != NIL ? car (args) : NIL); 3964 s_return (args != NIL ? car (args) : NIL);
3559 } 3965 }
3560 else 3966
3561 Error_0 ("illegal function"); 3967 Error_0 ("illegal function");
3562 3968
3563 case OP_DOMACRO: /* do macro */ 3969 case OP_DOMACRO: /* do macro */
3564 SCHEME_V->code = SCHEME_V->value; 3970 SCHEME_V->code = SCHEME_V->value;
3565 s_goto (OP_EVAL); 3971 s_goto (OP_EVAL);
3566
3567#if 1
3568 3972
3569 case OP_LAMBDA: /* lambda */ 3973 case OP_LAMBDA: /* lambda */
3570 /* If the hook is defined, apply it to SCHEME_V->code, otherwise 3974 /* If the hook is defined, apply it to SCHEME_V->code, otherwise
3571 set SCHEME_V->value fall thru */ 3975 set SCHEME_V->value fall thru */
3572 { 3976 {
… …
3579 SCHEME_V->code = slot_value_in_env (f); 3983 SCHEME_V->code = slot_value_in_env (f);
3580 s_goto (OP_APPLY); 3984 s_goto (OP_APPLY);
3581 } 3985 }
3582 3986
3583 SCHEME_V->value = SCHEME_V->code; 3987 SCHEME_V->value = SCHEME_V->code;
3584 /* Fallthru */
3585 } 3988 }
3989 /* Fallthru */
3586 3990
3587 case OP_LAMBDA1: 3991 case OP_LAMBDA1:
3588 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir)); 3992 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));
3589
3590#else
3591
3592 case OP_LAMBDA: /* lambda */
3593 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3594
3595#endif
3596 3993
3597 case OP_MKCLOSURE: /* make-closure */ 3994 case OP_MKCLOSURE: /* make-closure */
3598 x = car (args); 3995 x = car (args);
3599 3996
3600 if (car (x) == SCHEME_V->LAMBDA) 3997 if (car (x) == SCHEME_V->LAMBDA)
… …
3639 else 4036 else
3640 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 4037 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3641 4038
3642 s_return (SCHEME_V->code); 4039 s_return (SCHEME_V->code);
3643 4040
3644
3645 case OP_DEFP: /* defined? */ 4041 case OP_DEFP: /* defined? */
3646 x = SCHEME_V->envir; 4042 x = SCHEME_V->envir;
3647 4043
3648 if (cdr (args) != NIL) 4044 if (cdr (args) != NIL)
3649 x = cadr (args); 4045 x = cadr (args);
… …
3667 s_return (SCHEME_V->value); 4063 s_return (SCHEME_V->value);
3668 } 4064 }
3669 else 4065 else
3670 Error_1 ("set!: unbound variable:", SCHEME_V->code); 4066 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3671 4067
3672
3673 case OP_BEGIN: /* begin */ 4068 case OP_BEGIN: /* begin */
3674 if (!is_pair (SCHEME_V->code)) 4069 if (!is_pair (SCHEME_V->code))
3675 s_return (SCHEME_V->code); 4070 s_return (SCHEME_V->code);
3676 4071
3677 if (cdr (SCHEME_V->code) != NIL) 4072 if (cdr (SCHEME_V->code) != NIL)
… …
3688 case OP_IF1: /* if */ 4083 case OP_IF1: /* if */
3689 if (is_true (SCHEME_V->value)) 4084 if (is_true (SCHEME_V->value))
3690 SCHEME_V->code = car (SCHEME_V->code); 4085 SCHEME_V->code = car (SCHEME_V->code);
3691 else 4086 else
3692 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ 4087 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
4088
3693 s_goto (OP_EVAL); 4089 s_goto (OP_EVAL);
3694 4090
3695 case OP_LET0: /* let */ 4091 case OP_LET0: /* let */
3696 SCHEME_V->args = NIL; 4092 SCHEME_V->args = NIL;
3697 SCHEME_V->value = SCHEME_V->code; 4093 SCHEME_V->value = SCHEME_V->code;
3698 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); 4094 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3699 s_goto (OP_LET1); 4095 s_goto (OP_LET1);
3700 4096
3701 case OP_LET1: /* let (calculate parameters) */ 4097 case OP_LET1: /* let (calculate parameters) */
4098 case OP_LET1REC: /* letrec (calculate parameters) */
3702 args = cons (SCHEME_V->value, args); 4099 args = cons (SCHEME_V->value, args);
3703 4100
3704 if (is_pair (SCHEME_V->code)) /* continue */ 4101 if (is_pair (SCHEME_V->code)) /* continue */
3705 { 4102 {
3706 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 4103 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3707 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); 4104 Error_1 ("Bad syntax of binding spec in let/letrec:", car (SCHEME_V->code));
3708 4105
3709 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); 4106 s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code));
3710 SCHEME_V->code = cadar (SCHEME_V->code); 4107 SCHEME_V->code = cadar (SCHEME_V->code);
3711 SCHEME_V->args = NIL; 4108 SCHEME_V->args = NIL;
3712 s_goto (OP_EVAL); 4109 s_goto (OP_EVAL);
3713 } 4110 }
3714 else /* end */ 4111
3715 { 4112 /* end */
3716 args = reverse_in_place (SCHEME_A_ NIL, args); 4113 args = reverse_in_place (SCHEME_A_ NIL, args);
3717 SCHEME_V->code = car (args); 4114 SCHEME_V->code = car (args);
3718 SCHEME_V->args = cdr (args); 4115 SCHEME_V->args = cdr (args);
3719 s_goto (OP_LET2); 4116 s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC);
3720 }
3721 4117
3722 case OP_LET2: /* let */ 4118 case OP_LET2: /* let */
3723 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4119 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3724 4120
3725 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 4121 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
… …
3729 if (is_symbol (car (SCHEME_V->code))) /* named let */ 4125 if (is_symbol (car (SCHEME_V->code))) /* named let */
3730 { 4126 {
3731 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 4127 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3732 { 4128 {
3733 if (!is_pair (x)) 4129 if (!is_pair (x))
3734 Error_1 ("Bad syntax of binding in let :", x); 4130 Error_1 ("Bad syntax of binding in let:", x);
3735 4131
3736 if (!is_list (SCHEME_A_ car (x))) 4132 if (!is_list (SCHEME_A_ car (x)))
3737 Error_1 ("Bad syntax of binding in let :", car (x)); 4133 Error_1 ("Bad syntax of binding in let:", car (x));
3738 4134
3739 args = cons (caar (x), args); 4135 args = cons (caar (x), args);
3740 } 4136 }
3741 4137
3742 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)), 4138 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
… …
3759 SCHEME_V->code = cdr (SCHEME_V->code); 4155 SCHEME_V->code = cdr (SCHEME_V->code);
3760 s_goto (OP_BEGIN); 4156 s_goto (OP_BEGIN);
3761 } 4157 }
3762 4158
3763 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code))) 4159 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code)))
3764 Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code)); 4160 Error_1 ("Bad syntax of binding spec in let*:", car (SCHEME_V->code));
3765 4161
3766 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code)); 4162 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
3767 SCHEME_V->code = car (cdaar (SCHEME_V->code)); 4163 SCHEME_V->code = car (cdaar (SCHEME_V->code));
3768 s_goto (OP_EVAL); 4164 s_goto (OP_EVAL);
3769 4165
… …
3780 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code); 4176 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3781 SCHEME_V->code = cadar (SCHEME_V->code); 4177 SCHEME_V->code = cadar (SCHEME_V->code);
3782 SCHEME_V->args = NIL; 4178 SCHEME_V->args = NIL;
3783 s_goto (OP_EVAL); 4179 s_goto (OP_EVAL);
3784 } 4180 }
3785 else /* end */ 4181
4182 /* end */
3786 { 4183
3787 SCHEME_V->code = args; 4184 SCHEME_V->code = args;
3788 SCHEME_V->args = NIL; 4185 SCHEME_V->args = NIL;
3789 s_goto (OP_BEGIN); 4186 s_goto (OP_BEGIN);
3790 }
3791 4187
3792 case OP_LET0REC: /* letrec */ 4188 case OP_LET0REC: /* letrec */
3793 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4189 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3794 SCHEME_V->args = NIL; 4190 SCHEME_V->args = NIL;
3795 SCHEME_V->value = SCHEME_V->code; 4191 SCHEME_V->value = SCHEME_V->code;
3796 SCHEME_V->code = car (SCHEME_V->code); 4192 SCHEME_V->code = car (SCHEME_V->code);
3797 s_goto (OP_LET1REC); 4193 s_goto (OP_LET1REC);
3798 4194
3799 case OP_LET1REC: /* letrec (calculate parameters) */ 4195 /* OP_LET1REC handled by OP_LET1 */
3800 args = cons (SCHEME_V->value, args);
3801
3802 if (is_pair (SCHEME_V->code)) /* continue */
3803 {
3804 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3805 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3806
3807 s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3808 SCHEME_V->code = cadar (SCHEME_V->code);
3809 SCHEME_V->args = NIL;
3810 s_goto (OP_EVAL);
3811 }
3812 else /* end */
3813 {
3814 args = reverse_in_place (SCHEME_A_ NIL, args);
3815 SCHEME_V->code = car (args);
3816 SCHEME_V->args = cdr (args);
3817 s_goto (OP_LET2REC);
3818 }
3819 4196
3820 case OP_LET2REC: /* letrec */ 4197 case OP_LET2REC: /* letrec */
3821 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) 4198 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3822 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 4199 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3823 4200
… …
3853 } 4230 }
3854 else 4231 else
3855 { 4232 {
3856 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) 4233 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3857 s_return (NIL); 4234 s_return (NIL);
3858 else 4235
3859 {
3860 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 4236 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3861 SCHEME_V->code = caar (SCHEME_V->code); 4237 SCHEME_V->code = caar (SCHEME_V->code);
3862 s_goto (OP_EVAL); 4238 s_goto (OP_EVAL);
3863 }
3864 } 4239 }
3865 4240
3866 case OP_DELAY: /* delay */ 4241 case OP_DELAY: /* delay */
3867 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 4242 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3868 set_typeflag (x, T_PROMISE); 4243 set_typeflag (x, T_PROMISE);
… …
3879 case OP_AND1: /* and */ 4254 case OP_AND1: /* and */
3880 if (is_false (SCHEME_V->value)) 4255 if (is_false (SCHEME_V->value))
3881 s_return (SCHEME_V->value); 4256 s_return (SCHEME_V->value);
3882 else if (SCHEME_V->code == NIL) 4257 else if (SCHEME_V->code == NIL)
3883 s_return (SCHEME_V->value); 4258 s_return (SCHEME_V->value);
3884 else 4259
3885 {
3886 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 4260 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3887 SCHEME_V->code = car (SCHEME_V->code); 4261 SCHEME_V->code = car (SCHEME_V->code);
3888 s_goto (OP_EVAL); 4262 s_goto (OP_EVAL);
3889 }
3890 4263
3891 case OP_OR0: /* or */ 4264 case OP_OR0: /* or */
3892 if (SCHEME_V->code == NIL) 4265 if (SCHEME_V->code == NIL)
3893 s_return (S_F); 4266 s_return (S_F);
3894 4267
… …
3899 case OP_OR1: /* or */ 4272 case OP_OR1: /* or */
3900 if (is_true (SCHEME_V->value)) 4273 if (is_true (SCHEME_V->value))
3901 s_return (SCHEME_V->value); 4274 s_return (SCHEME_V->value);
3902 else if (SCHEME_V->code == NIL) 4275 else if (SCHEME_V->code == NIL)
3903 s_return (SCHEME_V->value); 4276 s_return (SCHEME_V->value);
3904 else 4277
3905 {
3906 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 4278 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3907 SCHEME_V->code = car (SCHEME_V->code); 4279 SCHEME_V->code = car (SCHEME_V->code);
3908 s_goto (OP_EVAL); 4280 s_goto (OP_EVAL);
3909 }
3910 4281
3911 case OP_C0STREAM: /* cons-stream */ 4282 case OP_C0STREAM: /* cons-stream */
3912 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 4283 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3913 SCHEME_V->code = car (SCHEME_V->code); 4284 SCHEME_V->code = car (SCHEME_V->code);
3914 s_goto (OP_EVAL); 4285 s_goto (OP_EVAL);
… …
3979 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x)); 4350 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3980 SCHEME_V->code = caar (x); 4351 SCHEME_V->code = caar (x);
3981 s_goto (OP_EVAL); 4352 s_goto (OP_EVAL);
3982 } 4353 }
3983 } 4354 }
3984 else 4355
3985 s_return (NIL); 4356 s_return (NIL);
3986 4357
3987 case OP_CASE2: /* case */ 4358 case OP_CASE2: /* case */
3988 if (is_true (SCHEME_V->value)) 4359 if (is_true (SCHEME_V->value))
3989 s_goto (OP_BEGIN); 4360 s_goto (OP_BEGIN);
3990 else 4361
3991 s_return (NIL); 4362 s_return (NIL);
3992 4363
3993 case OP_PAPPLY: /* apply */ 4364 case OP_PAPPLY: /* apply */
3994 SCHEME_V->code = car (args); 4365 SCHEME_V->code = car (args);
3995 SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); 4366 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3996 /*SCHEME_V->args = cadr(args); */ 4367 /*SCHEME_V->args = cadr(args); */
… …
4010 } 4381 }
4011 4382
4012 if (USE_ERROR_CHECKING) abort (); 4383 if (USE_ERROR_CHECKING) abort ();
4013} 4384}
4014 4385
4015static int 4386/* math, cxr */
4387ecb_hot static int
4016opexe_1 (SCHEME_P_ enum scheme_opcodes op) 4388opexe_1 (SCHEME_P_ enum scheme_opcodes op)
4017{ 4389{
4018 pointer args = SCHEME_V->args; 4390 pointer args = SCHEME_V->args;
4019 pointer x = car (args); 4391 pointer x = car (args);
4020 num v; 4392 num v;
4021 4393
4022 switch (op) 4394 switch (op)
4023 { 4395 {
4024#if USE_MATH 4396#if USE_MATH
4025 case OP_INEX2EX: /* inexact->exact */ 4397 case OP_INEX2EX: /* inexact->exact */
4026 {
4027 if (is_integer (x)) 4398 if (!is_integer (x))
4028 s_return (x); 4399 {
4029
4030 RVALUE r = rvalue_unchecked (x); 4400 RVALUE r = rvalue_unchecked (x);
4031 4401
4032 if (r == (RVALUE)(IVALUE)r) 4402 if (r == (RVALUE)(IVALUE)r)
4033 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4403 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4034 else 4404 else
4035 Error_1 ("inexact->exact: not integral:", x); 4405 Error_1 ("inexact->exact: not integral:", x);
4036 } 4406 }
4037 4407
4408 s_return (x);
4409
4410 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4411 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4412 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4413 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4414
4415 case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4038 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4416 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4039 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4417 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4418 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4040 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4419 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4041 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4420 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4042 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4421 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4043 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4422 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4044 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4423 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4045 4424
4046 case OP_ATAN: 4425 case OP_ATAN:
4426 s_return (mk_real (SCHEME_A_
4047 if (cdr (args) == NIL) 4427 cdr (args) == NIL
4048 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4428 ? atan (rvalue (x))
4049 else 4429 : atan2 (rvalue (x), rvalue (cadr (args)))));
4050 {
4051 pointer y = cadr (args);
4052 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4053 }
4054
4055 case OP_SQRT:
4056 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4057 4430
4058 case OP_EXPT: 4431 case OP_EXPT:
4059 { 4432 {
4060 RVALUE result; 4433 RVALUE result;
4061 int real_result = 1; 4434 int real_result = 1;
… …
4084 if (real_result) 4457 if (real_result)
4085 s_return (mk_real (SCHEME_A_ result)); 4458 s_return (mk_real (SCHEME_A_ result));
4086 else 4459 else
4087 s_return (mk_integer (SCHEME_A_ result)); 4460 s_return (mk_integer (SCHEME_A_ result));
4088 } 4461 }
4089
4090 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4091 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4092
4093 case OP_TRUNCATE:
4094 {
4095 RVALUE n = rvalue (x);
4096 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4097 }
4098
4099 case OP_ROUND:
4100 if (is_integer (x))
4101 s_return (x);
4102
4103 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4104#endif 4462#endif
4105 4463
4106 case OP_ADD: /* + */ 4464 case OP_ADD: /* + */
4107 v = num_zero; 4465 v = num_zero;
4108 4466
… …
4196 else 4554 else
4197 Error_0 ("modulo: division by zero"); 4555 Error_0 ("modulo: division by zero");
4198 4556
4199 s_return (mk_number (SCHEME_A_ v)); 4557 s_return (mk_number (SCHEME_A_ v));
4200 4558
4201 case OP_CAR: /* car */ 4559 /* the compiler will optimize this mess... */
4202 s_return (caar (args)); 4560 case OP_CAR: op_car: s_return (car (x));
4203 4561 case OP_CDR: op_cdr: s_return (cdr (x));
4204 case OP_CDR: /* cdr */ 4562 case OP_CAAR: op_caar: x = car (x); goto op_car;
4205 s_return (cdar (args)); 4563 case OP_CADR: op_cadr: x = cdr (x); goto op_car;
4564 case OP_CDAR: op_cdar: x = car (x); goto op_cdr;
4565 case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr;
4566 case OP_CAAAR: op_caaar: x = car (x); goto op_caar;
4567 case OP_CAADR: op_caadr: x = cdr (x); goto op_caar;
4568 case OP_CADAR: op_cadar: x = car (x); goto op_cadr;
4569 case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr;
4570 case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar;
4571 case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar;
4572 case OP_CDDAR: op_cddar: x = car (x); goto op_cddr;
4573 case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr;
4574 case OP_CAAAAR: x = car (x); goto op_caaar;
4575 case OP_CAAADR: x = cdr (x); goto op_caaar;
4576 case OP_CAADAR: x = car (x); goto op_caadr;
4577 case OP_CAADDR: x = cdr (x); goto op_caadr;
4578 case OP_CADAAR: x = car (x); goto op_cadar;
4579 case OP_CADADR: x = cdr (x); goto op_cadar;
4580 case OP_CADDAR: x = car (x); goto op_caddr;
4581 case OP_CADDDR: x = cdr (x); goto op_caddr;
4582 case OP_CDAAAR: x = car (x); goto op_cdaar;
4583 case OP_CDAADR: x = cdr (x); goto op_cdaar;
4584 case OP_CDADAR: x = car (x); goto op_cdadr;
4585 case OP_CDADDR: x = cdr (x); goto op_cdadr;
4586 case OP_CDDAAR: x = car (x); goto op_cddar;
4587 case OP_CDDADR: x = cdr (x); goto op_cddar;
4588 case OP_CDDDAR: x = car (x); goto op_cdddr;
4589 case OP_CDDDDR: x = cdr (x); goto op_cdddr;
4206 4590
4207 case OP_CONS: /* cons */ 4591 case OP_CONS: /* cons */
4208 set_cdr (args, cadr (args)); 4592 set_cdr (args, cadr (args));
4209 s_return (args); 4593 s_return (args);
4210 4594
… …
4384 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4768 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4385 4769
4386 s_return (newstr); 4770 s_return (newstr);
4387 } 4771 }
4388 4772
4389 case OP_SUBSTR: /* substring */ 4773 case OP_STRING_COPY: /* substring/string-copy */
4390 { 4774 {
4391 char *str = strvalue (x); 4775 char *str = strvalue (x);
4392 int index0 = ivalue_unchecked (cadr (args)); 4776 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4393 int index1; 4777 int index1;
4394 int len; 4778 int len;
4395 4779
4396 if (index0 > strlength (x)) 4780 if (index0 > strlength (x))
4397 Error_1 ("substring: start out of bounds:", cadr (args)); 4781 Error_1 ("string->copy: start out of bounds:", cadr (args));
4398 4782
4399 if (cddr (args) != NIL) 4783 if (cddr (args) != NIL)
4400 { 4784 {
4401 index1 = ivalue_unchecked (caddr (args)); 4785 index1 = ivalue_unchecked (caddr (args));
4402 4786
4403 if (index1 > strlength (x) || index1 < index0) 4787 if (index1 > strlength (x) || index1 < index0)
4404 Error_1 ("substring: end out of bounds:", caddr (args)); 4788 Error_1 ("string->copy: end out of bounds:", caddr (args));
4405 } 4789 }
4406 else 4790 else
4407 index1 = strlength (x); 4791 index1 = strlength (x);
4408 4792
4409 len = index1 - index0; 4793 len = index1 - index0;
4410 x = mk_empty_string (SCHEME_A_ len, ' '); 4794 x = mk_counted_string (SCHEME_A_ str + index0, len);
4411 memcpy (strvalue (x), str + index0, len);
4412 strvalue (x)[len] = 0;
4413 4795
4414 s_return (x); 4796 s_return (x);
4415 } 4797 }
4416 4798
4417 case OP_VECTOR: /* vector */ 4799 case OP_VECTOR: /* vector */
… …
4491 } 4873 }
4492 4874
4493 if (USE_ERROR_CHECKING) abort (); 4875 if (USE_ERROR_CHECKING) abort ();
4494} 4876}
4495 4877
4496static int 4878/* relational ops */
4879ecb_hot static int
4497opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4880opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4498{ 4881{
4499 pointer x = SCHEME_V->args; 4882 pointer x = SCHEME_V->args;
4500 4883
4501 for (;;) 4884 for (;;)
… …
4522 } 4905 }
4523 4906
4524 s_return (S_T); 4907 s_return (S_T);
4525} 4908}
4526 4909
4527static int 4910/* predicates */
4911ecb_hot static int
4528opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4912opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4529{ 4913{
4530 pointer args = SCHEME_V->args; 4914 pointer args = SCHEME_V->args;
4531 pointer a = car (args); 4915 pointer a = car (args);
4532 pointer d = cdr (args); 4916 pointer d = cdr (args);
… …
4579 } 4963 }
4580 4964
4581 s_retbool (r); 4965 s_retbool (r);
4582} 4966}
4583 4967
4584static int 4968/* promises, list ops, ports */
4969ecb_hot static int
4585opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4970opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4586{ 4971{
4587 pointer args = SCHEME_V->args; 4972 pointer args = SCHEME_V->args;
4588 pointer a = car (args); 4973 pointer a = car (args);
4589 pointer x, y; 4974 pointer x, y;
… …
4602 } 4987 }
4603 else 4988 else
4604 s_return (SCHEME_V->code); 4989 s_return (SCHEME_V->code);
4605 4990
4606 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4991 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4607 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4992 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4608 s_return (SCHEME_V->value); 4993 s_return (SCHEME_V->value);
4609 4994
4610#if USE_PORTS 4995#if USE_PORTS
4996
4997 case OP_EOF_OBJECT: /* eof-object */
4998 s_return (S_EOF);
4611 4999
4612 case OP_WRITE: /* write */ 5000 case OP_WRITE: /* write */
4613 case OP_DISPLAY: /* display */ 5001 case OP_DISPLAY: /* display */
4614 case OP_WRITE_CHAR: /* write-char */ 5002 case OP_WRITE_CHAR: /* write-char */
4615 if (is_pair (cdr (SCHEME_V->args))) 5003 if (is_pair (cdr (SCHEME_V->args)))
… …
4629 else 5017 else
4630 SCHEME_V->print_flag = 0; 5018 SCHEME_V->print_flag = 0;
4631 5019
4632 s_goto (OP_P0LIST); 5020 s_goto (OP_P0LIST);
4633 5021
5022 //TODO: move to scheme
4634 case OP_NEWLINE: /* newline */ 5023 case OP_NEWLINE: /* newline */
4635 if (is_pair (args)) 5024 if (is_pair (args))
4636 { 5025 {
4637 if (a != SCHEME_V->outport) 5026 if (a != SCHEME_V->outport)
4638 { 5027 {
… …
4640 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 5029 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4641 SCHEME_V->outport = a; 5030 SCHEME_V->outport = a;
4642 } 5031 }
4643 } 5032 }
4644 5033
4645 putstr (SCHEME_A_ "\n"); 5034 putcharacter (SCHEME_A_ '\n');
4646 s_return (S_T); 5035 s_return (S_T);
4647#endif 5036#endif
4648 5037
4649 case OP_ERR0: /* error */ 5038 case OP_ERR0: /* error */
4650 SCHEME_V->retcode = -1; 5039 SCHEME_V->retcode = -1;
… …
4659 putstr (SCHEME_A_ strvalue (car (args))); 5048 putstr (SCHEME_A_ strvalue (car (args)));
4660 SCHEME_V->args = cdr (args); 5049 SCHEME_V->args = cdr (args);
4661 s_goto (OP_ERR1); 5050 s_goto (OP_ERR1);
4662 5051
4663 case OP_ERR1: /* error */ 5052 case OP_ERR1: /* error */
4664 putstr (SCHEME_A_ " "); 5053 putcharacter (SCHEME_A_ ' ');
4665 5054
4666 if (args != NIL) 5055 if (args != NIL)
4667 { 5056 {
4668 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); 5057 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4669 SCHEME_V->args = a; 5058 SCHEME_V->args = a;
4670 SCHEME_V->print_flag = 1; 5059 SCHEME_V->print_flag = 1;
4671 s_goto (OP_P0LIST); 5060 s_goto (OP_P0LIST);
4672 } 5061 }
4673 else 5062 else
4674 { 5063 {
4675 putstr (SCHEME_A_ "\n"); 5064 putcharacter (SCHEME_A_ '\n');
4676 5065
4677 if (SCHEME_V->interactive_repl) 5066 if (SCHEME_V->interactive_repl)
4678 s_goto (OP_T0LVL); 5067 s_goto (OP_T0LVL);
4679 else 5068 else
4680 return -1; 5069 return -1;
… …
4757 SCHEME_V->gc_verbose = (a != S_F); 5146 SCHEME_V->gc_verbose = (a != S_F);
4758 s_retbool (was); 5147 s_retbool (was);
4759 } 5148 }
4760 5149
4761 case OP_NEWSEGMENT: /* new-segment */ 5150 case OP_NEWSEGMENT: /* new-segment */
5151#if 0
4762 if (!is_pair (args) || !is_number (a)) 5152 if (!is_pair (args) || !is_number (a))
4763 Error_0 ("new-segment: argument must be a number"); 5153 Error_0 ("new-segment: argument must be a number");
4764 5154#endif
4765 alloc_cellseg (SCHEME_A_ ivalue (a)); 5155 s_retbool (alloc_cellseg (SCHEME_A));
4766
4767 s_return (S_T);
4768 5156
4769 case OP_OBLIST: /* oblist */ 5157 case OP_OBLIST: /* oblist */
4770 s_return (oblist_all_symbols (SCHEME_A)); 5158 s_return (oblist_all_symbols (SCHEME_A));
4771 5159
4772#if USE_PORTS 5160#if USE_PORTS
… …
4842 s_return (p == NIL ? S_F : p); 5230 s_return (p == NIL ? S_F : p);
4843 } 5231 }
4844 5232
4845 case OP_GET_OUTSTRING: /* get-output-string */ 5233 case OP_GET_OUTSTRING: /* get-output-string */
4846 { 5234 {
4847 port *p; 5235 port *p = port (a);
4848 5236
4849 if ((p = a->object.port)->kind & port_string) 5237 if (p->kind & port_string)
4850 { 5238 {
4851 off_t size; 5239 off_t size;
4852 char *str; 5240 char *str;
4853 5241
4854 size = p->rep.string.curr - p->rep.string.start + 1; 5242 size = p->rep.string.curr - p->rep.string.start + 1;
… …
4889 } 5277 }
4890 5278
4891 if (USE_ERROR_CHECKING) abort (); 5279 if (USE_ERROR_CHECKING) abort ();
4892} 5280}
4893 5281
4894static int 5282/* reading */
5283ecb_cold static int
4895opexe_5 (SCHEME_P_ enum scheme_opcodes op) 5284opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4896{ 5285{
4897 pointer args = SCHEME_V->args; 5286 pointer args = SCHEME_V->args;
4898 pointer x; 5287 pointer x;
4899 5288
… …
4959 int res; 5348 int res;
4960 5349
4961 if (is_pair (args)) 5350 if (is_pair (args))
4962 p = car (args); 5351 p = car (args);
4963 5352
4964 res = p->object.port->kind & port_string; 5353 res = port (p)->kind & port_string;
4965 5354
4966 s_retbool (res); 5355 s_retbool (res);
4967 } 5356 }
4968 5357
4969 case OP_SET_INPORT: /* set-input-port */ 5358 case OP_SET_INPORT: /* set-input-port */
… …
4978 case OP_RDSEXPR: 5367 case OP_RDSEXPR:
4979 switch (SCHEME_V->tok) 5368 switch (SCHEME_V->tok)
4980 { 5369 {
4981 case TOK_EOF: 5370 case TOK_EOF:
4982 s_return (S_EOF); 5371 s_return (S_EOF);
4983 /* NOTREACHED */
4984 5372
4985 case TOK_VEC: 5373 case TOK_VEC:
4986 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL); 5374 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
4987 /* fall through */ 5375 /* fall through */
4988 5376
… …
4991 5379
4992 if (SCHEME_V->tok == TOK_RPAREN) 5380 if (SCHEME_V->tok == TOK_RPAREN)
4993 s_return (NIL); 5381 s_return (NIL);
4994 else if (SCHEME_V->tok == TOK_DOT) 5382 else if (SCHEME_V->tok == TOK_DOT)
4995 Error_0 ("syntax error: illegal dot expression"); 5383 Error_0 ("syntax error: illegal dot expression");
4996 else 5384
4997 {
4998 SCHEME_V->nesting_stack[SCHEME_V->file_i]++; 5385 SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
4999 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL); 5386 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
5000 s_goto (OP_RDSEXPR); 5387 s_goto (OP_RDSEXPR);
5001 }
5002 5388
5003 case TOK_QUOTE: 5389 case TOK_QUOTE:
5004 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL); 5390 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
5005 SCHEME_V->tok = token (SCHEME_A); 5391 SCHEME_V->tok = token (SCHEME_A);
5006 s_goto (OP_RDSEXPR); 5392 s_goto (OP_RDSEXPR);
… …
5012 { 5398 {
5013 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL); 5399 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5014 SCHEME_V->tok = TOK_LPAREN; 5400 SCHEME_V->tok = TOK_LPAREN;
5015 s_goto (OP_RDSEXPR); 5401 s_goto (OP_RDSEXPR);
5016 } 5402 }
5017 else 5403
5018 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); 5404 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5019
5020 s_goto (OP_RDSEXPR); 5405 s_goto (OP_RDSEXPR);
5021 5406
5022 case TOK_COMMA: 5407 case TOK_COMMA:
5023 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL); 5408 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
5024 SCHEME_V->tok = token (SCHEME_A); 5409 SCHEME_V->tok = token (SCHEME_A);
… …
5035 case TOK_DOTATOM: 5420 case TOK_DOTATOM:
5036 SCHEME_V->strbuff[0] = '.'; 5421 SCHEME_V->strbuff[0] = '.';
5037 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); 5422 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5038 5423
5039 case TOK_STRATOM: 5424 case TOK_STRATOM:
5425 //TODO: haven't checked whether the garbage collector could interfere and free x
5426 gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded
5040 x = readstrexp (SCHEME_A_ '|'); 5427 x = readstrexp (SCHEME_A_ '|');
5041 //TODO: haven't checked whether the garbage collector could interfere
5042 s_return (mk_atom (SCHEME_A_ strvalue (x))); 5428 s_return (mk_atom (SCHEME_A_ strvalue (x)));
5043 5429
5044 case TOK_DQUOTE: 5430 case TOK_DQUOTE:
5045 x = readstrexp (SCHEME_A_ '"'); 5431 x = readstrexp (SCHEME_A_ '"');
5046 5432
… …
5054 { 5440 {
5055 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1); 5441 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);
5056 5442
5057 if (f == NIL) 5443 if (f == NIL)
5058 Error_0 ("undefined sharp expression"); 5444 Error_0 ("undefined sharp expression");
5059 else 5445
5060 {
5061 SCHEME_V->code = cons (slot_value_in_env (f), NIL); 5446 SCHEME_V->code = cons (slot_value_in_env (f), NIL);
5062 s_goto (OP_EVAL); 5447 s_goto (OP_EVAL);
5063 }
5064 } 5448 }
5065 5449
5066 case TOK_SHARP_CONST: 5450 case TOK_SHARP_CONST:
5067 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL) 5451 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5068 Error_0 ("undefined sharp expression"); 5452 Error_0 ("undefined sharp expression");
5069 else 5453
5070 s_return (x); 5454 s_return (x);
5071 5455
5072 default: 5456 default:
5073 Error_0 ("syntax error: illegal token"); 5457 Error_0 ("syntax error: illegal token");
5074 } 5458 }
5075 5459
… …
5168 pointer b = cdr (args); 5552 pointer b = cdr (args);
5169 int ok_abbr = ok_abbrev (b); 5553 int ok_abbr = ok_abbrev (b);
5170 SCHEME_V->args = car (b); 5554 SCHEME_V->args = car (b);
5171 5555
5172 if (a == SCHEME_V->QUOTE && ok_abbr) 5556 if (a == SCHEME_V->QUOTE && ok_abbr)
5173 putstr (SCHEME_A_ "'"); 5557 putcharacter (SCHEME_A_ '\'');
5174 else if (a == SCHEME_V->QQUOTE && ok_abbr) 5558 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5175 putstr (SCHEME_A_ "`"); 5559 putcharacter (SCHEME_A_ '`');
5176 else if (a == SCHEME_V->UNQUOTE && ok_abbr) 5560 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5177 putstr (SCHEME_A_ ","); 5561 putcharacter (SCHEME_A_ ',');
5178 else if (a == SCHEME_V->UNQUOTESP && ok_abbr) 5562 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5179 putstr (SCHEME_A_ ",@"); 5563 putstr (SCHEME_A_ ",@");
5180 else 5564 else
5181 { 5565 {
5182 putstr (SCHEME_A_ "("); 5566 putcharacter (SCHEME_A_ '(');
5183 s_save (SCHEME_A_ OP_P1LIST, b, NIL); 5567 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5184 SCHEME_V->args = a; 5568 SCHEME_V->args = a;
5185 } 5569 }
5186 5570
5187 s_goto (OP_P0LIST); 5571 s_goto (OP_P0LIST);
… …
5189 5573
5190 case OP_P1LIST: 5574 case OP_P1LIST:
5191 if (is_pair (args)) 5575 if (is_pair (args))
5192 { 5576 {
5193 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); 5577 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5194 putstr (SCHEME_A_ " "); 5578 putcharacter (SCHEME_A_ ' ');
5195 SCHEME_V->args = car (args); 5579 SCHEME_V->args = car (args);
5196 s_goto (OP_P0LIST); 5580 s_goto (OP_P0LIST);
5197 } 5581 }
5198 else if (is_vector (args)) 5582 else if (is_vector (args))
5199 { 5583 {
… …
5207 { 5591 {
5208 putstr (SCHEME_A_ " . "); 5592 putstr (SCHEME_A_ " . ");
5209 printatom (SCHEME_A_ args, SCHEME_V->print_flag); 5593 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5210 } 5594 }
5211 5595
5212 putstr (SCHEME_A_ ")"); 5596 putcharacter (SCHEME_A_ ')');
5213 s_return (S_T); 5597 s_return (S_T);
5214 } 5598 }
5215 5599
5216 case OP_PVECFROM: 5600 case OP_PVECFROM:
5217 { 5601 {
… …
5219 pointer vec = car (args); 5603 pointer vec = car (args);
5220 int len = veclength (vec); 5604 int len = veclength (vec);
5221 5605
5222 if (i == len) 5606 if (i == len)
5223 { 5607 {
5224 putstr (SCHEME_A_ ")"); 5608 putcharacter (SCHEME_A_ ')');
5225 s_return (S_T); 5609 s_return (S_T);
5226 } 5610 }
5227 else 5611 else
5228 { 5612 {
5229 pointer elem = vector_get (vec, i); 5613 pointer elem = vector_get (vec, i);
… …
5231 ivalue_unchecked (cdr (args)) = i + 1; 5615 ivalue_unchecked (cdr (args)) = i + 1;
5232 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5616 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5233 SCHEME_V->args = elem; 5617 SCHEME_V->args = elem;
5234 5618
5235 if (i > 0) 5619 if (i > 0)
5236 putstr (SCHEME_A_ " "); 5620 putcharacter (SCHEME_A_ ' ');
5237 5621
5238 s_goto (OP_P0LIST); 5622 s_goto (OP_P0LIST);
5239 } 5623 }
5240 } 5624 }
5241 } 5625 }
5242 5626
5243 if (USE_ERROR_CHECKING) abort (); 5627 if (USE_ERROR_CHECKING) abort ();
5244} 5628}
5245 5629
5246static int 5630/* list ops */
5631ecb_hot static int
5247opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5632opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5248{ 5633{
5249 pointer args = SCHEME_V->args; 5634 pointer args = SCHEME_V->args;
5250 pointer a = car (args); 5635 pointer a = car (args);
5251 pointer x, y; 5636 pointer x, y;
… …
5274 break; 5659 break;
5275 } 5660 }
5276 5661
5277 if (is_pair (y)) 5662 if (is_pair (y))
5278 s_return (car (y)); 5663 s_return (car (y));
5279 else 5664
5280 s_return (S_F); 5665 s_return (S_F);
5281
5282 5666
5283 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5667 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5284 SCHEME_V->args = a; 5668 SCHEME_V->args = a;
5285 5669
5286 if (SCHEME_V->args == NIL) 5670 if (SCHEME_V->args == NIL)
5287 s_return (S_F); 5671 s_return (S_F);
5288 else if (is_closure (SCHEME_V->args)) 5672 else if (is_closure (SCHEME_V->args) || is_macro (SCHEME_V->args))
5289 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5673 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5290 else if (is_macro (SCHEME_V->args)) 5674
5291 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5292 else
5293 s_return (S_F); 5675 s_return (S_F);
5294 5676
5295 case OP_CLOSUREP: /* closure? */ 5677 case OP_CLOSUREP: /* closure? */
5296 /* 5678 /*
5297 * Note, macro object is also a closure. 5679 * Note, macro object is also a closure.
5298 * Therefore, (closure? <#MACRO>) ==> #t 5680 * Therefore, (closure? <#MACRO>) ==> #t
… …
5309 5691
5310/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5692/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5311typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); 5693typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5312 5694
5313typedef int (*test_predicate)(pointer); 5695typedef int (*test_predicate)(pointer);
5314static int 5696
5697ecb_hot static int
5315tst_any (pointer p) 5698tst_any (pointer p)
5316{ 5699{
5317 return 1; 5700 return 1;
5318} 5701}
5319 5702
5320static int 5703ecb_hot static int
5321tst_inonneg (pointer p) 5704tst_inonneg (pointer p)
5322{ 5705{
5323 return is_integer (p) && ivalue_unchecked (p) >= 0; 5706 return is_integer (p) && ivalue_unchecked (p) >= 0;
5324} 5707}
5325 5708
5326static int 5709ecb_hot static int
5327tst_is_list (SCHEME_P_ pointer p) 5710tst_is_list (SCHEME_P_ pointer p)
5328{ 5711{
5329 return p == NIL || is_pair (p); 5712 return p == NIL || is_pair (p);
5330} 5713}
5331 5714
… …
5374#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" 5757#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5375#include "opdefines.h" 5758#include "opdefines.h"
5376#undef OP_DEF 5759#undef OP_DEF
5377; 5760;
5378 5761
5379static const char * 5762ecb_cold static const char *
5380opname (int idx) 5763opname (int idx)
5381{ 5764{
5382 const char *name = opnames; 5765 const char *name = opnames;
5383 5766
5384 /* should do this at compile time, but would require external program, right? */ 5767 /* should do this at compile time, but would require external program, right? */
… …
5386 name += strlen (name) + 1; 5769 name += strlen (name) + 1;
5387 5770
5388 return *name ? name : "ILLEGAL"; 5771 return *name ? name : "ILLEGAL";
5389} 5772}
5390 5773
5391static const char * 5774ecb_cold static const char *
5392procname (pointer x) 5775procname (pointer x)
5393{ 5776{
5394 return opname (procnum (x)); 5777 return opname (procnum (x));
5395} 5778}
5396 5779
… …
5416#undef OP_DEF 5799#undef OP_DEF
5417 {0} 5800 {0}
5418}; 5801};
5419 5802
5420/* kernel of this interpreter */ 5803/* kernel of this interpreter */
5421static void ecb_hot 5804ecb_hot static void
5422Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5805Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5423{ 5806{
5424 SCHEME_V->op = op; 5807 SCHEME_V->op = op;
5425 5808
5426 for (;;) 5809 for (;;)
… …
5509 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) 5892 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5510 return; 5893 return;
5511 5894
5512 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5895 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5513 { 5896 {
5514 xwrstr ("No memory!\n"); 5897 putstr (SCHEME_A_ "No memory!\n");
5515 return; 5898 return;
5516 } 5899 }
5517 } 5900 }
5518} 5901}
5519 5902
5520/* ========== Initialization of internal keywords ========== */ 5903/* ========== Initialization of internal keywords ========== */
5521 5904
5522static void 5905ecb_cold static void
5523assign_syntax (SCHEME_P_ const char *name) 5906assign_syntax (SCHEME_P_ const char *name)
5524{ 5907{
5525 pointer x = oblist_add_by_name (SCHEME_A_ name); 5908 pointer x = oblist_add_by_name (SCHEME_A_ name);
5526 set_typeflag (x, typeflag (x) | T_SYNTAX); 5909 set_typeflag (x, typeflag (x) | T_SYNTAX);
5527} 5910}
5528 5911
5529static void 5912ecb_cold static void
5530assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5913assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5531{ 5914{
5532 pointer x = mk_symbol (SCHEME_A_ name); 5915 pointer x = mk_symbol (SCHEME_A_ name);
5533 pointer y = mk_proc (SCHEME_A_ op); 5916 pointer y = mk_proc (SCHEME_A_ op);
5534 new_slot_in_env (SCHEME_A_ x, y); 5917 new_slot_in_env (SCHEME_A_ x, y);
… …
5542 ivalue_unchecked (y) = op; 5925 ivalue_unchecked (y) = op;
5543 return y; 5926 return y;
5544} 5927}
5545 5928
5546/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5929/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5547static int 5930ecb_hot static int
5548syntaxnum (pointer p) 5931syntaxnum (pointer p)
5549{ 5932{
5550 const char *s = strvalue (p); 5933 const char *s = strvalue (p);
5551 5934
5552 switch (strlength (p)) 5935 switch (strlength (p))
… …
5631 6014
5632ecb_cold int 6015ecb_cold int
5633scheme_init (SCHEME_P) 6016scheme_init (SCHEME_P)
5634{ 6017{
5635 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 6018 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5636 pointer x; 6019
6020 /* this memset is not strictly correct, as we assume (intcache)
6021 * that memset 0 will also set pointers to 0, but memset does
6022 * of course not guarantee that. screw such systems.
6023 */
6024 memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5637 6025
5638 num_set_fixnum (num_zero, 1); 6026 num_set_fixnum (num_zero, 1);
5639 num_set_ivalue (num_zero, 0); 6027 num_set_ivalue (num_zero, 0);
5640 num_set_fixnum (num_one, 1); 6028 num_set_fixnum (num_one, 1);
5641 num_set_ivalue (num_one, 1); 6029 num_set_ivalue (num_one, 1);
… …
5653 SCHEME_V->save_inport = NIL; 6041 SCHEME_V->save_inport = NIL;
5654 SCHEME_V->loadport = NIL; 6042 SCHEME_V->loadport = NIL;
5655 SCHEME_V->nesting = 0; 6043 SCHEME_V->nesting = 0;
5656 SCHEME_V->interactive_repl = 0; 6044 SCHEME_V->interactive_repl = 0;
5657 6045
5658 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 6046 if (!alloc_cellseg (SCHEME_A))
5659 { 6047 {
5660#if USE_ERROR_CHECKING 6048#if USE_ERROR_CHECKING
5661 SCHEME_V->no_memory = 1; 6049 SCHEME_V->no_memory = 1;
5662 return 0; 6050 return 0;
5663#endif 6051#endif
5664 } 6052 }
5665 6053
5666 SCHEME_V->gc_verbose = 0; 6054 SCHEME_V->gc_verbose = 0;
5667 dump_stack_initialize (SCHEME_A); 6055 dump_stack_initialize (SCHEME_A);
5668 SCHEME_V->code = NIL; 6056 SCHEME_V->code = NIL;
5669 SCHEME_V->args = NIL; 6057 SCHEME_V->args = NIL;
5670 SCHEME_V->envir = NIL; 6058 SCHEME_V->envir = NIL;
6059 SCHEME_V->value = NIL;
5671 SCHEME_V->tracing = 0; 6060 SCHEME_V->tracing = 0;
5672 6061
5673 /* init NIL */ 6062 /* init NIL */
5674 set_typeflag (NIL, T_ATOM | T_MARK); 6063 set_typeflag (NIL, T_SPECIAL | T_ATOM);
5675 set_car (NIL, NIL); 6064 set_car (NIL, NIL);
5676 set_cdr (NIL, NIL); 6065 set_cdr (NIL, NIL);
5677 /* init T */ 6066 /* init T */
5678 set_typeflag (S_T, T_ATOM | T_MARK); 6067 set_typeflag (S_T, T_SPECIAL | T_ATOM);
5679 set_car (S_T, S_T); 6068 set_car (S_T, S_T);
5680 set_cdr (S_T, S_T); 6069 set_cdr (S_T, S_T);
5681 /* init F */ 6070 /* init F */
5682 set_typeflag (S_F, T_ATOM | T_MARK); 6071 set_typeflag (S_F, T_SPECIAL | T_ATOM);
5683 set_car (S_F, S_F); 6072 set_car (S_F, S_F);
5684 set_cdr (S_F, S_F); 6073 set_cdr (S_F, S_F);
5685 /* init EOF_OBJ */ 6074 /* init EOF_OBJ */
5686 set_typeflag (S_EOF, T_ATOM | T_MARK); 6075 set_typeflag (S_EOF, T_SPECIAL | T_ATOM);
5687 set_car (S_EOF, S_EOF); 6076 set_car (S_EOF, S_EOF);
5688 set_cdr (S_EOF, S_EOF); 6077 set_cdr (S_EOF, S_EOF);
5689 /* init sink */ 6078 /* init sink */
5690 set_typeflag (S_SINK, T_PAIR | T_MARK); 6079 set_typeflag (S_SINK, T_PAIR);
5691 set_car (S_SINK, NIL); 6080 set_car (S_SINK, NIL);
5692 6081
5693 /* init c_nest */ 6082 /* init c_nest */
5694 SCHEME_V->c_nest = NIL; 6083 SCHEME_V->c_nest = NIL;
5695 6084
5696 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 6085 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5697 /* init global_env */ 6086 /* init global_env */
5698 new_frame_in_env (SCHEME_A_ NIL); 6087 new_frame_in_env (SCHEME_A_ NIL);
5699 SCHEME_V->global_env = SCHEME_V->envir; 6088 SCHEME_V->global_env = SCHEME_V->envir;
5700 /* init else */ 6089 /* init else */
5701 x = mk_symbol (SCHEME_A_ "else"); 6090 new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), S_T);
5702 new_slot_in_env (SCHEME_A_ x, S_T);
5703 6091
5704 { 6092 {
5705 static const char *syntax_names[] = { 6093 static const char *syntax_names[] = {
5706 "lambda", "quote", "define", "if", "begin", "set!", 6094 "lambda", "quote", "define", "if", "begin", "set!",
5707 "let", "let*", "letrec", "cond", "delay", "and", 6095 "let", "let*", "letrec", "cond", "delay", "and",
… …
5731 6119
5732 return !SCHEME_V->no_memory; 6120 return !SCHEME_V->no_memory;
5733} 6121}
5734 6122
5735#if USE_PORTS 6123#if USE_PORTS
5736void 6124ecb_cold void
5737scheme_set_input_port_file (SCHEME_P_ int fin) 6125scheme_set_input_port_file (SCHEME_P_ int fin)
5738{ 6126{
5739 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 6127 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5740} 6128}
5741 6129
5742void 6130ecb_cold void
5743scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 6131scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5744{ 6132{
5745 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 6133 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5746} 6134}
5747 6135
5748void 6136ecb_cold void
5749scheme_set_output_port_file (SCHEME_P_ int fout) 6137scheme_set_output_port_file (SCHEME_P_ int fout)
5750{ 6138{
5751 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 6139 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5752} 6140}
5753 6141
5754void 6142ecb_cold void
5755scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 6143scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5756{ 6144{
5757 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 6145 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5758} 6146}
5759#endif 6147#endif
5760 6148
5761void 6149ecb_cold void
5762scheme_set_external_data (SCHEME_P_ void *p) 6150scheme_set_external_data (SCHEME_P_ void *p)
5763{ 6151{
5764 SCHEME_V->ext_data = p; 6152 SCHEME_V->ext_data = p;
5765} 6153}
5766 6154
… …
5798 SCHEME_V->loadport = NIL; 6186 SCHEME_V->loadport = NIL;
5799 SCHEME_V->gc_verbose = 0; 6187 SCHEME_V->gc_verbose = 0;
5800 gc (SCHEME_A_ NIL, NIL); 6188 gc (SCHEME_A_ NIL, NIL);
5801 6189
5802 for (i = 0; i <= SCHEME_V->last_cell_seg; i++) 6190 for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5803 free (SCHEME_V->alloc_seg[i]); 6191 free (SCHEME_V->cell_seg[i]);
5804 6192
5805#if SHOW_ERROR_LINE 6193#if SHOW_ERROR_LINE
5806 for (i = 0; i <= SCHEME_V->file_i; i++) 6194 for (i = 0; i <= SCHEME_V->file_i; i++)
5807 {
5808 if (SCHEME_V->load_stack[i].kind & port_file) 6195 if (SCHEME_V->load_stack[i].kind & port_file)
5809 { 6196 {
5810 fname = SCHEME_V->load_stack[i].rep.stdio.filename; 6197 fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5811 6198
5812 if (fname) 6199 if (fname)
5813 free (fname); 6200 free (fname);
5814 } 6201 }
5815 }
5816#endif 6202#endif
5817} 6203}
5818 6204
5819void 6205ecb_cold void
5820scheme_load_file (SCHEME_P_ int fin) 6206scheme_load_file (SCHEME_P_ int fin)
5821{ 6207{
5822 scheme_load_named_file (SCHEME_A_ fin, 0); 6208 scheme_load_named_file (SCHEME_A_ fin, 0);
5823} 6209}
5824 6210
5825void 6211ecb_cold void
5826scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 6212scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5827{ 6213{
5828 dump_stack_reset (SCHEME_A); 6214 dump_stack_reset (SCHEME_A);
5829 SCHEME_V->envir = SCHEME_V->global_env; 6215 SCHEME_V->envir = SCHEME_V->global_env;
5830 SCHEME_V->file_i = 0; 6216 SCHEME_V->file_i = 0;
5831 SCHEME_V->load_stack[0].unget = -1; 6217 SCHEME_V->load_stack[0].unget = -1;
5832 SCHEME_V->load_stack[0].kind = port_input | port_file; 6218 SCHEME_V->load_stack[0].kind = port_input | port_file;
5833 SCHEME_V->load_stack[0].rep.stdio.file = fin; 6219 SCHEME_V->load_stack[0].rep.stdio.file = fin;
5834#if USE_PORTS
5835 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 6220 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5836#endif
5837 SCHEME_V->retcode = 0; 6221 SCHEME_V->retcode = 0;
5838 6222
5839#if USE_PORTS
5840 if (fin == STDIN_FILENO) 6223 if (fin == STDIN_FILENO)
5841 SCHEME_V->interactive_repl = 1; 6224 SCHEME_V->interactive_repl = 1;
5842#endif
5843 6225
5844#if USE_PORTS 6226#if USE_PORTS
5845#if SHOW_ERROR_LINE 6227#if SHOW_ERROR_LINE
5846 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0; 6228 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5847 6229
… …
5851#endif 6233#endif
5852 6234
5853 SCHEME_V->inport = SCHEME_V->loadport; 6235 SCHEME_V->inport = SCHEME_V->loadport;
5854 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6236 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5855 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6237 Eval_Cycle (SCHEME_A_ OP_T0LVL);
6238
5856 set_typeflag (SCHEME_V->loadport, T_ATOM); 6239 set_typeflag (SCHEME_V->loadport, T_ATOM);
5857 6240
5858 if (SCHEME_V->retcode == 0) 6241 if (SCHEME_V->retcode == 0)
5859 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6242 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5860} 6243}
5861 6244
5862void 6245ecb_cold void
5863scheme_load_string (SCHEME_P_ const char *cmd) 6246scheme_load_string (SCHEME_P_ const char *cmd)
5864{ 6247{
6248#if USE_PORTs
5865 dump_stack_reset (SCHEME_A); 6249 dump_stack_reset (SCHEME_A);
5866 SCHEME_V->envir = SCHEME_V->global_env; 6250 SCHEME_V->envir = SCHEME_V->global_env;
5867 SCHEME_V->file_i = 0; 6251 SCHEME_V->file_i = 0;
5868 SCHEME_V->load_stack[0].kind = port_input | port_string; 6252 SCHEME_V->load_stack[0].kind = port_input | port_string;
5869 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ 6253 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5870 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); 6254 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5871 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; 6255 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5872#if USE_PORTS
5873 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 6256 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5874#endif
5875 SCHEME_V->retcode = 0; 6257 SCHEME_V->retcode = 0;
5876 SCHEME_V->interactive_repl = 0; 6258 SCHEME_V->interactive_repl = 0;
5877 SCHEME_V->inport = SCHEME_V->loadport; 6259 SCHEME_V->inport = SCHEME_V->loadport;
5878 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6260 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5879 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6261 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5880 set_typeflag (SCHEME_V->loadport, T_ATOM); 6262 set_typeflag (SCHEME_V->loadport, T_ATOM);
5881 6263
5882 if (SCHEME_V->retcode == 0) 6264 if (SCHEME_V->retcode == 0)
5883 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6265 SCHEME_V->retcode = SCHEME_V->nesting != 0;
6266#else
6267 abort ();
6268#endif
5884} 6269}
5885 6270
5886void 6271ecb_cold void
5887scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 6272scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5888{ 6273{
5889 pointer x; 6274 pointer x;
5890 6275
5891 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 6276 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5896 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 6281 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5897} 6282}
5898 6283
5899#if !STANDALONE 6284#if !STANDALONE
5900 6285
5901void 6286ecb_cold void
5902scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 6287scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5903{ 6288{
5904 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 6289 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5905} 6290}
5906 6291
5907void 6292ecb_cold void
5908scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 6293scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5909{ 6294{
5910 int i; 6295 int i;
5911 6296
5912 for (i = 0; i < count; i++) 6297 for (i = 0; i < count; i++)
5913 scheme_register_foreign_func (SCHEME_A_ list + i); 6298 scheme_register_foreign_func (SCHEME_A_ list + i);
5914} 6299}
5915 6300
5916pointer 6301ecb_cold pointer
5917scheme_apply0 (SCHEME_P_ const char *procname) 6302scheme_apply0 (SCHEME_P_ const char *procname)
5918{ 6303{
5919 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 6304 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5920} 6305}
5921 6306
5922void 6307ecb_cold void
5923save_from_C_call (SCHEME_P) 6308save_from_C_call (SCHEME_P)
5924{ 6309{
5925 pointer saved_data = cons (car (S_SINK), 6310 pointer saved_data = cons (car (S_SINK),
5926 cons (SCHEME_V->envir, 6311 cons (SCHEME_V->envir,
5927 SCHEME_V->dump)); 6312 SCHEME_V->dump));
… …
5931 /* Truncate the dump stack so TS will return here when done, not 6316 /* Truncate the dump stack so TS will return here when done, not
5932 directly resume pre-C-call operations. */ 6317 directly resume pre-C-call operations. */
5933 dump_stack_reset (SCHEME_A); 6318 dump_stack_reset (SCHEME_A);
5934} 6319}
5935 6320
5936void 6321ecb_cold void
5937restore_from_C_call (SCHEME_P) 6322restore_from_C_call (SCHEME_P)
5938{ 6323{
5939 set_car (S_SINK, caar (SCHEME_V->c_nest)); 6324 set_car (S_SINK, caar (SCHEME_V->c_nest));
5940 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 6325 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5941 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 6326 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5942 /* Pop */ 6327 /* Pop */
5943 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 6328 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5944} 6329}
5945 6330
5946/* "func" and "args" are assumed to be already eval'ed. */ 6331/* "func" and "args" are assumed to be already eval'ed. */
5947pointer 6332ecb_cold pointer
5948scheme_call (SCHEME_P_ pointer func, pointer args) 6333scheme_call (SCHEME_P_ pointer func, pointer args)
5949{ 6334{
5950 int old_repl = SCHEME_V->interactive_repl; 6335 int old_repl = SCHEME_V->interactive_repl;
5951 6336
5952 SCHEME_V->interactive_repl = 0; 6337 SCHEME_V->interactive_repl = 0;
… …
5959 SCHEME_V->interactive_repl = old_repl; 6344 SCHEME_V->interactive_repl = old_repl;
5960 restore_from_C_call (SCHEME_A); 6345 restore_from_C_call (SCHEME_A);
5961 return SCHEME_V->value; 6346 return SCHEME_V->value;
5962} 6347}
5963 6348
5964pointer 6349ecb_cold pointer
5965scheme_eval (SCHEME_P_ pointer obj) 6350scheme_eval (SCHEME_P_ pointer obj)
5966{ 6351{
5967 int old_repl = SCHEME_V->interactive_repl; 6352 int old_repl = SCHEME_V->interactive_repl;
5968 6353
5969 SCHEME_V->interactive_repl = 0; 6354 SCHEME_V->interactive_repl = 0;
… …
5981 6366
5982/* ========== Main ========== */ 6367/* ========== Main ========== */
5983 6368
5984#if STANDALONE 6369#if STANDALONE
5985 6370
5986int 6371ecb_cold int
5987main (int argc, char **argv) 6372main (int argc, char **argv)
5988{ 6373{
5989# if USE_MULTIPLICITY 6374# if USE_MULTIPLICITY
5990 scheme ssc; 6375 scheme ssc;
5991 scheme *const SCHEME_V = &ssc; 6376 scheme *const SCHEME_V = &ssc;
… …
5993# endif 6378# endif
5994 int fin; 6379 int fin;
5995 char *file_name = InitFile; 6380 char *file_name = InitFile;
5996 int retcode; 6381 int retcode;
5997 int isfile = 1; 6382 int isfile = 1;
6383#if EXPERIMENT
5998 system ("ps v $PPID");//D 6384 system ("ps v $PPID");
6385#endif
5999 6386
6000 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6387 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6001 { 6388 {
6002 xwrstr ("Usage: tinyscheme -?\n"); 6389 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6003 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6390 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6004 xwrstr ("followed by\n"); 6391 putstr (SCHEME_A_ "followed by\n");
6005 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6392 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6006 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6393 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6007 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6394 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6008 xwrstr ("Use - as filename for stdin.\n"); 6395 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6009 return 1; 6396 return 1;
6010 } 6397 }
6011 6398
6012 if (!scheme_init (SCHEME_A)) 6399 if (!scheme_init (SCHEME_A))
6013 { 6400 {
6014 xwrstr ("Could not initialize!\n"); 6401 putstr (SCHEME_A_ "Could not initialize!\n");
6015 return 2; 6402 return 2;
6016 } 6403 }
6017 6404
6018# if USE_PORTS 6405# if USE_PORTS
6019 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6406 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6032 } 6419 }
6033#endif 6420#endif
6034 6421
6035 do 6422 do
6036 { 6423 {
6037#if USE_PORTS
6038 if (strcmp (file_name, "-") == 0) 6424 if (strcmp (file_name, "-") == 0)
6039 fin = STDIN_FILENO; 6425 fin = STDIN_FILENO;
6040 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) 6426 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
6041 { 6427 {
6042 pointer args = NIL; 6428 pointer args = NIL;
… …
6060 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args); 6446 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
6061 6447
6062 } 6448 }
6063 else 6449 else
6064 fin = open (file_name, O_RDONLY); 6450 fin = open (file_name, O_RDONLY);
6065#endif
6066 6451
6067 if (isfile && fin < 0) 6452 if (isfile && fin < 0)
6068 { 6453 {
6069 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6454 putstr (SCHEME_A_ "Could not open file ");
6455 putstr (SCHEME_A_ file_name);
6456 putcharacter (SCHEME_A_ '\n');
6070 } 6457 }
6071 else 6458 else
6072 { 6459 {
6073 if (isfile) 6460 if (isfile)
6074 scheme_load_named_file (SCHEME_A_ fin, file_name); 6461 scheme_load_named_file (SCHEME_A_ fin, file_name);
6075 else 6462 else
6076 scheme_load_string (SCHEME_A_ file_name); 6463 scheme_load_string (SCHEME_A_ file_name);
6077 6464
6078#if USE_PORTS
6079 if (!isfile || fin != STDIN_FILENO) 6465 if (!isfile || fin != STDIN_FILENO)
6080 { 6466 {
6081 if (SCHEME_V->retcode != 0) 6467 if (SCHEME_V->retcode != 0)
6082 { 6468 {
6083 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6469 putstr (SCHEME_A_ "Errors encountered reading ");
6470 putstr (SCHEME_A_ file_name);
6471 putcharacter (SCHEME_A_ '\n');
6084 } 6472 }
6085 6473
6086 if (isfile) 6474 if (isfile)
6087 close (fin); 6475 close (fin);
6088 } 6476 }
6089#endif
6090 } 6477 }
6091 6478
6092 file_name = *argv++; 6479 file_name = *argv++;
6093 } 6480 }
6094 while (file_name != 0); 6481 while (file_name != 0);

Diff Legend

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