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.35 by root, Sun Nov 29 00:02:21 2015 UTC vs.
Revision 1.64 by root, Wed Dec 2 17:01:18 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 PAGE_SIZE 4096 /* does not work on sparc/alpha */ 21#define _GNU_SOURCE 1
22#include "malloc.c" 22#define _POSIX_C_SOURCE 200201
23#define _XOPEN_SOURCE 600
24
23 25
24#define SCHEME_SOURCE 26#define SCHEME_SOURCE
25#include "scheme-private.h" 27#include "scheme-private.h"
26#ifndef WIN32 28#ifndef WIN32
27# include <unistd.h> 29# include <unistd.h>
28#endif 30#endif
29#if USE_MATH 31#if USE_MATH
30# include <math.h> 32# include <math.h>
31#endif 33#endif
32 34
35#define ECB_NO_THREADS 1
33#include "ecb.h" 36#include "ecb.h"
34 37
35#include <sys/types.h> 38#include <sys/types.h>
36#include <sys/stat.h> 39#include <sys/stat.h>
37#include <fcntl.h> 40#include <fcntl.h>
… …
45#include <string.h> 48#include <string.h>
46 49
47#include <limits.h> 50#include <limits.h>
48#include <inttypes.h> 51#include <inttypes.h>
49#include <float.h> 52#include <float.h>
50//#include <ctype.h> 53
54#if !USE_SYSTEM_MALLOC
55# define PAGE_SIZE 4096 /* does not work on sparc/alpha */
56# include "malloc.c"
57# define malloc(n) tiny_malloc (n)
58# define realloc(p,n) tiny_realloc (p, n)
59# define free(p) tiny_free (p)
60#endif
51 61
52#if '1' != '0' + 1 \ 62#if '1' != '0' + 1 \
53 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \ 63 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
54 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \ 64 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
55 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \ 65 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
… …
74 TOK_SHARP_CONST, 84 TOK_SHARP_CONST,
75 TOK_VEC 85 TOK_VEC
76}; 86};
77 87
78#define BACKQUOTE '`' 88#define BACKQUOTE '`'
79#define DELIMITERS "()\";\f\t\v\n\r " 89#define WHITESPACE " \t\r\n\v\f"
90#define DELIMITERS "()\";" WHITESPACE
80 91
81#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 92#define NIL POINTER (&SCHEME_V->xNIL)
82#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 93#define S_T POINTER (&SCHEME_V->xT)
83#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 94#define S_F POINTER (&SCHEME_V->xF)
84#define S_SINK (&SCHEME_V->xsink) 95#define S_SINK POINTER (&SCHEME_V->xsink)
85#define S_EOF (&SCHEME_V->xEOF_OBJ) 96#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
86 97
87#if !USE_MULTIPLICITY 98#if !USE_MULTIPLICITY
88static scheme sc; 99static scheme sc;
89#endif 100#endif
90 101
91static void 102ecb_cold static void
92xbase (char *s, long n, int base) 103xbase (char *s, long n, int base)
93{ 104{
94 if (n < 0) 105 if (n < 0)
95 { 106 {
96 *s++ = '-'; 107 *s++ = '-';
… …
98 } 109 }
99 110
100 char *p = s; 111 char *p = s;
101 112
102 do { 113 do {
103 *p++ = '0' + n % base; 114 *p++ = "0123456789abcdef"[n % base];
104 n /= base; 115 n /= base;
105 } while (n); 116 } while (n);
106 117
107 *p-- = 0; 118 *p-- = 0;
108 119
… …
111 char x = *s; *s = *p; *p = x; 122 char x = *s; *s = *p; *p = x;
112 --p; ++s; 123 --p; ++s;
113 } 124 }
114} 125}
115 126
116static void 127ecb_cold static void
117xnum (char *s, long n) 128xnum (char *s, long n)
118{ 129{
119 xbase (s, n, 10); 130 xbase (s, n, 10);
120} 131}
121 132
122static void 133ecb_cold static void
123xwrstr (const char *s) 134putnum (SCHEME_P_ long n)
124{
125 write (1, s, strlen (s));
126}
127
128static void
129xwrnum (long n)
130{ 135{
131 char buf[64]; 136 char buf[64];
132 137
133 xnum (buf, n); 138 xnum (buf, n);
134 xwrstr (buf); 139 putstr (SCHEME_A_ buf);
135} 140}
141
142#if USE_CHAR_CLASSIFIERS
143#include <ctype.h>
144#else
136 145
137static char 146static char
138xtoupper (char c) 147xtoupper (char c)
139{ 148{
140 if (c >= 'a' && c <= 'z') 149 if (c >= 'a' && c <= 'z')
… …
160 169
161#define toupper(c) xtoupper (c) 170#define toupper(c) xtoupper (c)
162#define tolower(c) xtolower (c) 171#define tolower(c) xtolower (c)
163#define isdigit(c) xisdigit (c) 172#define isdigit(c) xisdigit (c)
164 173
174#endif
175
165#if USE_IGNORECASE 176#if USE_IGNORECASE
166static const char * 177ecb_cold static const char *
167xstrlwr (char *s) 178xstrlwr (char *s)
168{ 179{
169 const char *p = s; 180 const char *p = s;
170 181
171 while (*s) 182 while (*s)
… …
184# define stricmp(a,b) strcmp (a, b) 195# define stricmp(a,b) strcmp (a, b)
185# define strlwr(s) (s) 196# define strlwr(s) (s)
186#endif 197#endif
187 198
188#ifndef prompt 199#ifndef prompt
189# define prompt "ts> " 200# define prompt "ms> "
190#endif 201#endif
191 202
192#ifndef InitFile 203#ifndef InitFile
193# define InitFile "init.scm" 204# define InitFile "init.scm"
194#endif 205#endif
195 206
196#ifndef FIRST_CELLSEGS
197# define FIRST_CELLSEGS 3
198#endif
199
200enum scheme_types 207enum scheme_types
201{ 208{
202 T_INTEGER, 209 T_INTEGER,
210 T_CHARACTER,
203 T_REAL, 211 T_REAL,
204 T_STRING, 212 T_STRING,
205 T_SYMBOL, 213 T_SYMBOL,
206 T_PROC, 214 T_PROC,
207 T_PAIR, /* also used for free cells */ 215 T_PAIR, /* also used for free cells */
208 T_CLOSURE, 216 T_CLOSURE,
217 T_BYTECODE, // temp
218 T_MACRO,
209 T_CONTINUATION, 219 T_CONTINUATION,
210 T_FOREIGN, 220 T_FOREIGN,
211 T_CHARACTER,
212 T_PORT, 221 T_PORT,
213 T_VECTOR, 222 T_VECTOR,
214 T_MACRO,
215 T_PROMISE, 223 T_PROMISE,
216 T_ENVIRONMENT, 224 T_ENVIRONMENT,
217 /* one more... */ 225
218 T_NUM_SYSTEM_TYPES 226 T_NUM_SYSTEM_TYPES
219}; 227};
220 228
221#define T_MASKTYPE 0x000f 229#define T_MASKTYPE 0x000f
222#define T_SYNTAX 0x0010 230#define T_SYNTAX 0x0010
… …
255static num num_op (enum num_op op, num a, num b); 263static num num_op (enum num_op op, num a, num b);
256static num num_intdiv (num a, num b); 264static num num_intdiv (num a, num b);
257static num num_rem (num a, num b); 265static num num_rem (num a, num b);
258static num num_mod (num a, num b); 266static num num_mod (num a, num b);
259 267
260#if USE_MATH
261static double round_per_R5RS (double x);
262#endif
263static int is_zero_rvalue (RVALUE x); 268static int is_zero_rvalue (RVALUE x);
264 269
265static num num_zero; 270static num num_zero;
266static num num_one; 271static num num_one;
267 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
268/* macros for cell operations */ 277/* macros for cell operations */
269#define typeflag(p) ((p)->flag + 0) 278#define typeflag(p) (CELL(p)->flag + 0)
270#define set_typeflag(p,v) ((p)->flag = (v)) 279#define set_typeflag(p,v) (CELL(p)->flag = (v))
271#define type(p) (typeflag (p) & T_MASKTYPE) 280#define type(p) (typeflag (p) & T_MASKTYPE)
272 281
273INTERFACE int 282INTERFACE int
274is_string (pointer p) 283is_string (pointer p)
275{ 284{
276 return type (p) == T_STRING; 285 return type (p) == T_STRING;
277} 286}
278 287
279#define strvalue(p) ((p)->object.string.svalue) 288#define strvalue(p) (CELL(p)->object.string.svalue)
280#define strlength(p) ((p)->object.string.length) 289#define strlength(p) (CELL(p)->object.string.length)
281 290
282INTERFACE int 291INTERFACE int
283is_vector (pointer p) 292is_vector (pointer p)
284{ 293{
285 return type (p) == T_VECTOR; 294 return type (p) == T_VECTOR;
286} 295}
287 296
288#define vecvalue(p) ((p)->object.vector.vvalue) 297#define vecvalue(p) (CELL(p)->object.vector.vvalue)
289#define veclength(p) ((p)->object.vector.length) 298#define veclength(p) (CELL(p)->object.vector.length)
290INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); 299INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
291INTERFACE pointer vector_get (pointer vec, uint32_t ielem); 300INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
292INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); 301INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
293 302
294INTERFACE int 303INTERFACE int
… …
320string_value (pointer p) 329string_value (pointer p)
321{ 330{
322 return strvalue (p); 331 return strvalue (p);
323} 332}
324 333
325#define ivalue_unchecked(p) (p)->object.ivalue 334#define ivalue_unchecked(p) CELL(p)->object.ivalue
326#define set_ivalue(p,v) (p)->object.ivalue = (v) 335#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
327 336
328#if USE_REAL 337#if USE_REAL
329#define rvalue_unchecked(p) (p)->object.rvalue 338#define rvalue_unchecked(p) CELL(p)->object.rvalue
330#define set_rvalue(p,v) (p)->object.rvalue = (v) 339#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
331#else 340#else
332#define rvalue_unchecked(p) (p)->object.ivalue 341#define rvalue_unchecked(p) CELL(p)->object.ivalue
333#define set_rvalue(p,v) (p)->object.ivalue = (v) 342#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
334#endif 343#endif
335 344
336INTERFACE long 345INTERFACE long
337charvalue (pointer p) 346charvalue (pointer p)
338{ 347{
339 return ivalue_unchecked (p); 348 return ivalue_unchecked (p);
340} 349}
341 350
351#define port(p) CELL(p)->object.port
352#define set_port(p,v) port(p) = (v)
342INTERFACE int 353INTERFACE int
343is_port (pointer p) 354is_port (pointer p)
344{ 355{
345 return type (p) == T_PORT; 356 return type (p) == T_PORT;
346} 357}
347 358
348INTERFACE int 359INTERFACE int
349is_inport (pointer p) 360is_inport (pointer p)
350{ 361{
351 return is_port (p) && p->object.port->kind & port_input; 362 return is_port (p) && port (p)->kind & port_input;
352} 363}
353 364
354INTERFACE int 365INTERFACE int
355is_outport (pointer p) 366is_outport (pointer p)
356{ 367{
357 return is_port (p) && p->object.port->kind & port_output; 368 return is_port (p) && port (p)->kind & port_output;
358} 369}
359 370
360INTERFACE int 371INTERFACE int
361is_pair (pointer p) 372is_pair (pointer p)
362{ 373{
363 return type (p) == T_PAIR; 374 return type (p) == T_PAIR;
364} 375}
365 376
366#define car(p) ((p)->object.cons.car + 0) 377#define car(p) (POINTER (CELL(p)->object.cons.car))
367#define cdr(p) ((p)->object.cons.cdr + 0) 378#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
368 379
369static pointer caar (pointer p) { return car (car (p)); } 380static pointer caar (pointer p) { return car (car (p)); }
370static pointer cadr (pointer p) { return car (cdr (p)); } 381static pointer cadr (pointer p) { return car (cdr (p)); }
371static pointer cdar (pointer p) { return cdr (car (p)); } 382static pointer cdar (pointer p) { return cdr (car (p)); }
372static pointer cddr (pointer p) { return cdr (cdr (p)); } 383static pointer cddr (pointer p) { return cdr (cdr (p)); }
373 384
374static pointer cadar (pointer p) { return car (cdr (car (p))); } 385static pointer cadar (pointer p) { return car (cdr (car (p))); }
375static pointer caddr (pointer p) { return car (cdr (cdr (p))); } 386static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
376static pointer cdaar (pointer p) { return cdr (car (car (p))); } 387static pointer cdaar (pointer p) { return cdr (car (car (p))); }
377 388
389static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); }
390
378INTERFACE void 391INTERFACE void
379set_car (pointer p, pointer q) 392set_car (pointer p, pointer q)
380{ 393{
381 p->object.cons.car = q; 394 CELL(p)->object.cons.car = CELL (q);
382} 395}
383 396
384INTERFACE void 397INTERFACE void
385set_cdr (pointer p, pointer q) 398set_cdr (pointer p, pointer q)
386{ 399{
387 p->object.cons.cdr = q; 400 CELL(p)->object.cons.cdr = CELL (q);
388} 401}
389 402
390INTERFACE pointer 403INTERFACE pointer
391pair_car (pointer p) 404pair_car (pointer p)
392{ 405{
… …
406} 419}
407 420
408INTERFACE char * 421INTERFACE char *
409symname (pointer p) 422symname (pointer p)
410{ 423{
411 return strvalue (car (p)); 424 return strvalue (p);
412} 425}
413 426
414#if USE_PLIST 427#if USE_PLIST
428#error plists are broken because symbols are no longer pairs
429#define symprop(p) cdr(p)
415SCHEME_EXPORT int 430SCHEME_EXPORT int
416hasprop (pointer p) 431hasprop (pointer p)
417{ 432{
418 return typeflag (p) & T_SYMBOL; 433 return typeflag (p) & T_SYMBOL;
419} 434}
420
421# define symprop(p) cdr(p)
422#endif 435#endif
423 436
424INTERFACE int 437INTERFACE int
425is_syntax (pointer p) 438is_syntax (pointer p)
426{ 439{
… …
440} 453}
441 454
442INTERFACE char * 455INTERFACE char *
443syntaxname (pointer p) 456syntaxname (pointer p)
444{ 457{
445 return strvalue (car (p)); 458 return strvalue (p);
446} 459}
447 460
448#define procnum(p) ivalue_unchecked (p) 461#define procnum(p) ivalue_unchecked (p)
449static const char *procname (pointer x); 462static const char *procname (pointer x);
450 463
… …
522 proper list: length 535 proper list: length
523 circular list: -1 536 circular list: -1
524 not even a pair: -2 537 not even a pair: -2
525 dotted list: -2 minus length before dot 538 dotted list: -2 minus length before dot
526*/ 539*/
527INTERFACE int 540ecb_hot INTERFACE int
528list_length (SCHEME_P_ pointer a) 541list_length (SCHEME_P_ pointer a)
529{ 542{
530 int i = 0; 543 int i = 0;
531 pointer slow, fast; 544 pointer slow, fast;
532 545
… …
571{ 584{
572 return list_length (SCHEME_A_ a) >= 0; 585 return list_length (SCHEME_A_ a) >= 0;
573} 586}
574 587
575#if USE_CHAR_CLASSIFIERS 588#if USE_CHAR_CLASSIFIERS
589
576ecb_inline int 590ecb_inline int
577Cisalpha (int c) 591Cisalpha (int c)
578{ 592{
579 return isascii (c) && isalpha (c); 593 return isascii (c) && isalpha (c);
580} 594}
… …
638 "gs", 652 "gs",
639 "rs", 653 "rs",
640 "us" 654 "us"
641}; 655};
642 656
643static int 657ecb_cold static int
644is_ascii_name (const char *name, int *pc) 658is_ascii_name (const char *name, int *pc)
645{ 659{
646 int i; 660 int i;
647 661
648 for (i = 0; i < 32; i++) 662 for (i = 0; i < 32; i++)
… …
667 681
668static int file_push (SCHEME_P_ const char *fname); 682static int file_push (SCHEME_P_ const char *fname);
669static void file_pop (SCHEME_P); 683static void file_pop (SCHEME_P);
670static int file_interactive (SCHEME_P); 684static int file_interactive (SCHEME_P);
671ecb_inline int is_one_of (const char *s, int c); 685ecb_inline int is_one_of (const char *s, int c);
672static int alloc_cellseg (SCHEME_P_ int n); 686static int alloc_cellseg (SCHEME_P);
673ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 687ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
674static void finalize_cell (SCHEME_P_ pointer a); 688static void finalize_cell (SCHEME_P_ pointer a);
675static int count_consecutive_cells (pointer x, int needed);
676static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 689static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
677static pointer mk_number (SCHEME_P_ const num n); 690static pointer mk_number (SCHEME_P_ const num n);
678static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 691static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
679static pointer mk_vector (SCHEME_P_ uint32_t len); 692static pointer mk_vector (SCHEME_P_ uint32_t len);
680static pointer mk_atom (SCHEME_P_ char *q); 693static pointer mk_atom (SCHEME_P_ char *q);
681static pointer mk_sharp_const (SCHEME_P_ char *name); 694static pointer mk_sharp_const (SCHEME_P_ char *name);
682 695
696static pointer mk_port (SCHEME_P_ port *p);
697
683#if USE_PORTS 698#if USE_PORTS
684static pointer mk_port (SCHEME_P_ port *p);
685static pointer port_from_filename (SCHEME_P_ const char *fn, int prop); 699static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
686static pointer port_from_file (SCHEME_P_ int, int prop); 700static pointer port_from_file (SCHEME_P_ int, int prop);
687static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 701static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
688static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop); 702static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop);
689static port *port_rep_from_file (SCHEME_P_ int, int prop); 703static port *port_rep_from_file (SCHEME_P_ int, int prop);
690static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 704static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
691static void port_close (SCHEME_P_ pointer p, int flag); 705static void port_close (SCHEME_P_ pointer p, int flag);
692#endif 706#endif
707
693static void mark (pointer a); 708static void mark (pointer a);
694static void gc (SCHEME_P_ pointer a, pointer b); 709static void gc (SCHEME_P_ pointer a, pointer b);
695static int basic_inchar (port *pt); 710static int basic_inchar (port *pt);
696static int inchar (SCHEME_P); 711static int inchar (SCHEME_P);
697static void backchar (SCHEME_P_ int c); 712static void backchar (SCHEME_P_ int c);
698static char *readstr_upto (SCHEME_P_ int skip, const char *delim); 713static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
699static pointer readstrexp (SCHEME_P_ char delim); 714static pointer readstrexp (SCHEME_P_ char delim);
700ecb_inline int skipspace (SCHEME_P); 715static int skipspace (SCHEME_P);
701static int token (SCHEME_P); 716static int token (SCHEME_P);
702static void printslashstring (SCHEME_P_ char *s, int len); 717static void printslashstring (SCHEME_P_ char *s, int len);
703static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 718static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
704static void printatom (SCHEME_P_ pointer l, int f); 719static void printatom (SCHEME_P_ pointer l, int f);
705static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 720static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
871 } 886 }
872 887
873 return ret; 888 return ret;
874} 889}
875 890
876#if USE_MATH
877
878/* Round to nearest. Round to even if midway */
879static double
880round_per_R5RS (double x)
881{
882 double fl = floor (x);
883 double ce = ceil (x);
884 double dfl = x - fl;
885 double dce = ce - x;
886
887 if (dfl > dce)
888 return ce;
889 else if (dfl < dce)
890 return fl;
891 else
892 {
893 if (fmod (fl, 2) == 0) /* I imagine this holds */
894 return fl;
895 else
896 return ce;
897 }
898}
899#endif
900
901static int 891static int
902is_zero_rvalue (RVALUE x) 892is_zero_rvalue (RVALUE x)
903{ 893{
904 return x == 0; 894 return x == 0;
905#if 0 895#if 0
… …
910#endif 900#endif
911#endif 901#endif
912} 902}
913 903
914/* allocate new cell segment */ 904/* allocate new cell segment */
915static int 905ecb_cold static int
916alloc_cellseg (SCHEME_P_ int n) 906alloc_cellseg (SCHEME_P)
917{ 907{
918 pointer newp; 908 struct cell *newp;
919 pointer last; 909 struct cell *last;
920 pointer p; 910 struct cell *p;
921 char *cp; 911 char *cp;
922 long i; 912 long i;
923 int k; 913 int k;
924 914
925 static int segsize = CELL_SEGSIZE >> 1; 915 static int segsize = CELL_SEGSIZE >> 1;
926 segsize <<= 1; 916 segsize <<= 1;
927 917
928 for (k = 0; k < n; k++)
929 {
930 if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
931 return k;
932
933 cp = malloc (segsize * sizeof (struct cell)); 918 cp = malloc (segsize * sizeof (struct cell));
934 919
935 if (!cp && USE_ERROR_CHECKING) 920 if (!cp && USE_ERROR_CHECKING)
936 return k; 921 return k;
937 922
938 i = ++SCHEME_V->last_cell_seg; 923 i = ++SCHEME_V->last_cell_seg;
939 SCHEME_V->alloc_seg[i] = cp;
940 924
941 newp = (pointer)cp; 925 newp = (struct cell *)cp;
942 SCHEME_V->cell_seg[i] = newp; 926 SCHEME_V->cell_seg[i] = newp;
943 SCHEME_V->cell_segsize[i] = segsize; 927 SCHEME_V->cell_segsize[i] = segsize;
944 SCHEME_V->fcells += segsize; 928 SCHEME_V->fcells += segsize;
945 last = newp + segsize - 1; 929 last = newp + segsize - 1;
946 930
947 for (p = newp; p <= last; p++) 931 for (p = newp; p <= last; p++)
948 { 932 {
933 pointer cp = POINTER (p);
949 set_typeflag (p, T_PAIR); 934 set_typeflag (cp, T_PAIR);
950 set_car (p, NIL); 935 set_car (cp, NIL);
951 set_cdr (p, p + 1); 936 set_cdr (cp, POINTER (p + 1));
952 } 937 }
953 938
954 set_cdr (last, SCHEME_V->free_cell); 939 set_cdr (POINTER (last), SCHEME_V->free_cell);
955 SCHEME_V->free_cell = newp; 940 SCHEME_V->free_cell = POINTER (newp);
956 }
957 941
958 return n; 942 return 1;
959} 943}
960 944
961/* get new cell. parameter a, b is marked by gc. */ 945/* get new cell. parameter a, b is marked by gc. */
962ecb_inline pointer 946ecb_inline pointer
963get_cell_x (SCHEME_P_ pointer a, pointer b) 947get_cell_x (SCHEME_P_ pointer a, pointer b)
… …
967 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 951 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
968 return S_SINK; 952 return S_SINK;
969 953
970 if (SCHEME_V->free_cell == NIL) 954 if (SCHEME_V->free_cell == NIL)
971 { 955 {
972 const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; 956 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
973 957
974 gc (SCHEME_A_ a, b); 958 gc (SCHEME_A_ a, b);
975 959
976 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 960 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
977 { 961 {
978 /* if only a few recovered, get more to avoid fruitless gc's */ 962 /* if only a few recovered, get more to avoid fruitless gc's */
979 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 963 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
980 { 964 {
981#if USE_ERROR_CHECKING 965#if USE_ERROR_CHECKING
982 SCHEME_V->no_memory = 1; 966 SCHEME_V->no_memory = 1;
983 return S_SINK; 967 return S_SINK;
984#endif 968#endif
… …
996 } 980 }
997} 981}
998 982
999/* To retain recent allocs before interpreter knows about them - 983/* To retain recent allocs before interpreter knows about them -
1000 Tehom */ 984 Tehom */
1001 985ecb_hot static void
1002static void
1003push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 986push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1004{ 987{
1005 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 988 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1006 989
1007 set_typeflag (holder, T_PAIR); 990 set_typeflag (holder, T_PAIR);
… …
1009 set_car (holder, recent); 992 set_car (holder, recent);
1010 set_cdr (holder, car (S_SINK)); 993 set_cdr (holder, car (S_SINK));
1011 set_car (S_SINK, holder); 994 set_car (S_SINK, holder);
1012} 995}
1013 996
1014static pointer 997ecb_hot static pointer
1015get_cell (SCHEME_P_ pointer a, pointer b) 998get_cell (SCHEME_P_ pointer a, pointer b)
1016{ 999{
1017 pointer cell = get_cell_x (SCHEME_A_ a, b); 1000 pointer cell = get_cell_x (SCHEME_A_ a, b);
1018 1001
1019 /* For right now, include "a" and "b" in "cell" so that gc doesn't 1002 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1028} 1011}
1029 1012
1030static pointer 1013static pointer
1031get_vector_object (SCHEME_P_ uint32_t len, pointer init) 1014get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1032{ 1015{
1033 pointer v = get_cell_x (SCHEME_A_ 0, 0); 1016 pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1034 pointer *e = malloc (len * sizeof (pointer)); 1017 pointer *e = malloc (len * sizeof (pointer));
1035 1018
1036 if (!e && USE_ERROR_CHECKING) 1019 if (!e && USE_ERROR_CHECKING)
1037 return S_SINK; 1020 return S_SINK;
1038 1021
1039 /* Record it as a vector so that gc understands it. */ 1022 /* Record it as a vector so that gc understands it. */
1040 set_typeflag (v, T_VECTOR | T_ATOM); 1023 set_typeflag (v, T_VECTOR | T_ATOM);
1041 1024
1042 v->object.vector.vvalue = e; 1025 CELL(v)->object.vector.vvalue = e;
1043 v->object.vector.length = len; 1026 CELL(v)->object.vector.length = len;
1044 fill_vector (v, 0, init); 1027 fill_vector (v, 0, init);
1045 push_recent_alloc (SCHEME_A_ v, NIL); 1028 push_recent_alloc (SCHEME_A_ v, NIL);
1046 1029
1047 return v; 1030 return v;
1048} 1031}
… …
1057static void 1040static void
1058check_cell_alloced (pointer p, int expect_alloced) 1041check_cell_alloced (pointer p, int expect_alloced)
1059{ 1042{
1060 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ 1043 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1061 if (typeflag (p) & !expect_alloced) 1044 if (typeflag (p) & !expect_alloced)
1062 xwrstr ("Cell is already allocated!\n"); 1045 putstr (SCHEME_A_ "Cell is already allocated!\n");
1063 1046
1064 if (!(typeflag (p)) & expect_alloced) 1047 if (!(typeflag (p)) & expect_alloced)
1065 xwrstr ("Cell is not allocated!\n"); 1048 putstr (SCHEME_A_ "Cell is not allocated!\n");
1066} 1049}
1067 1050
1068static void 1051static void
1069check_range_alloced (pointer p, int n, int expect_alloced) 1052check_range_alloced (pointer p, int n, int expect_alloced)
1070{ 1053{
… …
1076#endif 1059#endif
1077 1060
1078/* Medium level cell allocation */ 1061/* Medium level cell allocation */
1079 1062
1080/* get new cons cell */ 1063/* get new cons cell */
1081pointer 1064ecb_hot static pointer
1082xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1065xcons (SCHEME_P_ pointer a, pointer b)
1083{ 1066{
1084 pointer x = get_cell (SCHEME_A_ a, b); 1067 pointer x = get_cell (SCHEME_A_ a, b);
1085 1068
1086 set_typeflag (x, T_PAIR); 1069 set_typeflag (x, T_PAIR);
1087
1088 if (immutable)
1089 setimmutable (x);
1090 1070
1091 set_car (x, a); 1071 set_car (x, a);
1092 set_cdr (x, b); 1072 set_cdr (x, b);
1093 1073
1094 return x; 1074 return x;
1095} 1075}
1096 1076
1097/* ========== oblist implementation ========== */
1098
1099static pointer 1077ecb_hot static pointer
1078ximmutable_cons (SCHEME_P_ pointer a, pointer b)
1079{
1080 pointer x = xcons (SCHEME_A_ a, b);
1081 setimmutable (x);
1082 return x;
1083}
1084
1085#define cons(a,b) xcons (SCHEME_A_ a, b)
1086#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1087
1088ecb_cold static pointer
1100generate_symbol (SCHEME_P_ const char *name) 1089generate_symbol (SCHEME_P_ const char *name)
1101{ 1090{
1102 pointer x = mk_string (SCHEME_A_ name); 1091 pointer x = mk_string (SCHEME_A_ name);
1103 setimmutable (x); 1092 setimmutable (x);
1104 x = immutable_cons (x, NIL);
1105 set_typeflag (x, T_SYMBOL); 1093 set_typeflag (x, T_SYMBOL | T_ATOM);
1106 return x; 1094 return x;
1107} 1095}
1096
1097/* ========== oblist implementation ========== */
1108 1098
1109#ifndef USE_OBJECT_LIST 1099#ifndef USE_OBJECT_LIST
1110 1100
1111static int 1101static int
1112hash_fn (const char *key, int table_size) 1102hash_fn (const char *key, int table_size)
1113{ 1103{
1114 const unsigned char *p = key; 1104 const unsigned char *p = (unsigned char *)key;
1115 uint32_t hash = 2166136261; 1105 uint32_t hash = 2166136261U;
1116 1106
1117 while (*p) 1107 while (*p)
1118 hash = (hash ^ *p++) * 16777619; 1108 hash = (hash ^ *p++) * 16777619;
1119 1109
1120 return hash % table_size; 1110 return hash % table_size;
1121} 1111}
1122 1112
1123static pointer 1113ecb_cold static pointer
1124oblist_initial_value (SCHEME_P) 1114oblist_initial_value (SCHEME_P)
1125{ 1115{
1126 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1116 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1127} 1117}
1128 1118
1129/* returns the new symbol */ 1119/* returns the new symbol */
1130static pointer 1120ecb_cold static pointer
1131oblist_add_by_name (SCHEME_P_ const char *name) 1121oblist_add_by_name (SCHEME_P_ const char *name)
1132{ 1122{
1133 pointer x = generate_symbol (SCHEME_A_ name); 1123 pointer x = generate_symbol (SCHEME_A_ name);
1134 int location = hash_fn (name, veclength (SCHEME_V->oblist)); 1124 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1135 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); 1125 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1136 return x; 1126 return x;
1137} 1127}
1138 1128
1139ecb_inline pointer 1129ecb_cold static pointer
1140oblist_find_by_name (SCHEME_P_ const char *name) 1130oblist_find_by_name (SCHEME_P_ const char *name)
1141{ 1131{
1142 int location; 1132 int location;
1143 pointer x; 1133 pointer x;
1144 char *s; 1134 char *s;
… …
1155 } 1145 }
1156 1146
1157 return NIL; 1147 return NIL;
1158} 1148}
1159 1149
1160static pointer 1150ecb_cold static pointer
1161oblist_all_symbols (SCHEME_P) 1151oblist_all_symbols (SCHEME_P)
1162{ 1152{
1163 int i; 1153 int i;
1164 pointer x; 1154 pointer x;
1165 pointer ob_list = NIL; 1155 pointer ob_list = NIL;
… …
1171 return ob_list; 1161 return ob_list;
1172} 1162}
1173 1163
1174#else 1164#else
1175 1165
1176static pointer 1166ecb_cold static pointer
1177oblist_initial_value (SCHEME_P) 1167oblist_initial_value (SCHEME_P)
1178{ 1168{
1179 return NIL; 1169 return NIL;
1180} 1170}
1181 1171
1182ecb_inline pointer 1172ecb_cold static pointer
1183oblist_find_by_name (SCHEME_P_ const char *name) 1173oblist_find_by_name (SCHEME_P_ const char *name)
1184{ 1174{
1185 pointer x; 1175 pointer x;
1186 char *s; 1176 char *s;
1187 1177
… …
1196 1186
1197 return NIL; 1187 return NIL;
1198} 1188}
1199 1189
1200/* returns the new symbol */ 1190/* returns the new symbol */
1201static pointer 1191ecb_cold static pointer
1202oblist_add_by_name (SCHEME_P_ const char *name) 1192oblist_add_by_name (SCHEME_P_ const char *name)
1203{ 1193{
1204 pointer x = mk_string (SCHEME_A_ name); 1194 pointer x = generate_symbol (SCHEME_A_ name);
1205 set_typeflag (x, T_SYMBOL);
1206 setimmutable (x);
1207 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1195 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1208 return x; 1196 return x;
1209} 1197}
1210 1198
1211static pointer 1199ecb_cold static pointer
1212oblist_all_symbols (SCHEME_P) 1200oblist_all_symbols (SCHEME_P)
1213{ 1201{
1214 return SCHEME_V->oblist; 1202 return SCHEME_V->oblist;
1215} 1203}
1216 1204
1217#endif 1205#endif
1218 1206
1219#if USE_PORTS
1220static pointer 1207ecb_cold static pointer
1221mk_port (SCHEME_P_ port *p) 1208mk_port (SCHEME_P_ port *p)
1222{ 1209{
1223 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1210 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1224 1211
1225 set_typeflag (x, T_PORT | T_ATOM); 1212 set_typeflag (x, T_PORT | T_ATOM);
1226 x->object.port = p; 1213 set_port (x, p);
1227 1214
1228 return x; 1215 return x;
1229} 1216}
1230#endif
1231 1217
1232pointer 1218ecb_cold pointer
1233mk_foreign_func (SCHEME_P_ foreign_func f) 1219mk_foreign_func (SCHEME_P_ foreign_func f)
1234{ 1220{
1235 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1221 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1236 1222
1237 set_typeflag (x, (T_FOREIGN | T_ATOM)); 1223 set_typeflag (x, T_FOREIGN | T_ATOM);
1238 x->object.ff = f; 1224 CELL(x)->object.ff = f;
1239 1225
1240 return x; 1226 return x;
1241} 1227}
1242 1228
1243INTERFACE pointer 1229INTERFACE pointer
1244mk_character (SCHEME_P_ int c) 1230mk_character (SCHEME_P_ int c)
1245{ 1231{
1246 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1232 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1247 1233
1248 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1234 set_typeflag (x, T_CHARACTER | T_ATOM);
1249 set_ivalue (x, c & 0xff); 1235 set_ivalue (x, c & 0xff);
1250 1236
1251 return x; 1237 return x;
1252} 1238}
1253 1239
1254/* get number atom (integer) */ 1240/* get number atom (integer) */
1255INTERFACE pointer 1241INTERFACE pointer
1256mk_integer (SCHEME_P_ long n) 1242mk_integer (SCHEME_P_ long n)
1257{ 1243{
1244 pointer p = 0;
1245 pointer *pp = &p;
1246
1247#if USE_INTCACHE
1248 if (n >= INTCACHE_MIN && n <= INTCACHE_MAX)
1249 pp = &SCHEME_V->intcache[n - INTCACHE_MIN];
1250#endif
1251
1252 if (!*pp)
1253 {
1258 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1254 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1259 1255
1260 set_typeflag (x, (T_INTEGER | T_ATOM)); 1256 set_typeflag (x, T_INTEGER | T_ATOM);
1257 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
1261 set_ivalue (x, n); 1258 set_ivalue (x, n);
1262 1259
1260 *pp = x;
1261 }
1262
1263 return x; 1263 return *pp;
1264} 1264}
1265 1265
1266INTERFACE pointer 1266INTERFACE pointer
1267mk_real (SCHEME_P_ RVALUE n) 1267mk_real (SCHEME_P_ RVALUE n)
1268{ 1268{
1269#if USE_REAL 1269#if USE_REAL
1270 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1270 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1271 1271
1272 set_typeflag (x, (T_REAL | T_ATOM)); 1272 set_typeflag (x, T_REAL | T_ATOM);
1273 set_rvalue (x, n); 1273 set_rvalue (x, n);
1274 1274
1275 return x; 1275 return x;
1276#else 1276#else
1277 return mk_integer (SCHEME_A_ n); 1277 return mk_integer (SCHEME_A_ n);
… …
1354 1354
1355 for (i = start; i < veclength (vec); i++) 1355 for (i = start; i < veclength (vec); i++)
1356 vecvalue (vec)[i] = obj; 1356 vecvalue (vec)[i] = obj;
1357} 1357}
1358 1358
1359INTERFACE void
1360vector_resize (pointer vec, uint32_t newsize, pointer fill)
1361{
1362 uint32_t oldsize = veclength (vec);
1363 vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer));
1364 veclength (vec) = newsize;
1365 fill_vector (vec, oldsize, fill);
1366}
1367
1359INTERFACE pointer 1368INTERFACE pointer
1360vector_get (pointer vec, uint32_t ielem) 1369vector_get (pointer vec, uint32_t ielem)
1361{ 1370{
1362 return vecvalue(vec)[ielem]; 1371 return vecvalue(vec)[ielem];
1363} 1372}
… …
1379 x = oblist_add_by_name (SCHEME_A_ name); 1388 x = oblist_add_by_name (SCHEME_A_ name);
1380 1389
1381 return x; 1390 return x;
1382} 1391}
1383 1392
1384INTERFACE pointer 1393ecb_cold INTERFACE pointer
1385gensym (SCHEME_P) 1394gensym (SCHEME_P)
1386{ 1395{
1387 pointer x; 1396 pointer x;
1388 char name[40] = "gensym-"; 1397 char name[40] = "gensym-";
1389 xnum (name + 7, SCHEME_V->gensym_cnt); 1398 xnum (name + 7, ++SCHEME_V->gensym_cnt);
1390 1399
1391 return generate_symbol (SCHEME_A_ name); 1400 return generate_symbol (SCHEME_A_ name);
1392} 1401}
1393 1402
1403static int
1404is_gensym (SCHEME_P_ pointer x)
1405{
1406 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1407}
1408
1394/* make symbol or number atom from string */ 1409/* make symbol or number atom from string */
1395static pointer 1410ecb_cold static pointer
1396mk_atom (SCHEME_P_ char *q) 1411mk_atom (SCHEME_P_ char *q)
1397{ 1412{
1398 char c, *p; 1413 char c, *p;
1399 int has_dec_point = 0; 1414 int has_dec_point = 0;
1400 int has_fp_exp = 0; 1415 int has_fp_exp = 0;
… …
1471 1486
1472 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1487 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1473} 1488}
1474 1489
1475/* make constant */ 1490/* make constant */
1476static pointer 1491ecb_cold static pointer
1477mk_sharp_const (SCHEME_P_ char *name) 1492mk_sharp_const (SCHEME_P_ char *name)
1478{ 1493{
1479 if (!strcmp (name, "t")) 1494 if (!strcmp (name, "t"))
1480 return S_T; 1495 return S_T;
1481 else if (!strcmp (name, "f")) 1496 else if (!strcmp (name, "f"))
1482 return S_F; 1497 return S_F;
1483 else if (*name == '\\') /* #\w (character) */ 1498 else if (*name == '\\') /* #\w (character) */
1484 { 1499 {
1485 int c; 1500 int c;
1486 1501
1502 // TODO: optimise
1487 if (stricmp (name + 1, "space") == 0) 1503 if (stricmp (name + 1, "space") == 0)
1488 c = ' '; 1504 c = ' ';
1489 else if (stricmp (name + 1, "newline") == 0) 1505 else if (stricmp (name + 1, "newline") == 0)
1490 c = '\n'; 1506 c = '\n';
1491 else if (stricmp (name + 1, "return") == 0) 1507 else if (stricmp (name + 1, "return") == 0)
1492 c = '\r'; 1508 c = '\r';
1493 else if (stricmp (name + 1, "tab") == 0) 1509 else if (stricmp (name + 1, "tab") == 0)
1494 c = '\t'; 1510 c = '\t';
1511 else if (stricmp (name + 1, "alarm") == 0)
1512 c = 0x07;
1513 else if (stricmp (name + 1, "backspace") == 0)
1514 c = 0x08;
1515 else if (stricmp (name + 1, "escape") == 0)
1516 c = 0x1b;
1517 else if (stricmp (name + 1, "delete") == 0)
1518 c = 0x7f;
1519 else if (stricmp (name + 1, "null") == 0)
1520 c = 0;
1495 else if (name[1] == 'x' && name[2] != 0) 1521 else if (name[1] == 'x' && name[2] != 0)
1496 { 1522 {
1497 long c1 = strtol (name + 2, 0, 16); 1523 long c1 = strtol (name + 2, 0, 16);
1498 1524
1499 if (0 <= c1 && c1 <= UCHAR_MAX) 1525 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1524 return NIL; 1550 return NIL;
1525 } 1551 }
1526} 1552}
1527 1553
1528/* ========== garbage collector ========== */ 1554/* ========== garbage collector ========== */
1555
1556static void
1557finalize_cell (SCHEME_P_ pointer a)
1558{
1559 /* TODO, fast bitmap check? */
1560 if (is_string (a) || is_symbol (a))
1561 free (strvalue (a));
1562 else if (is_vector (a))
1563 free (vecvalue (a));
1564#if USE_PORTS
1565 else if (is_port (a))
1566 {
1567 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1568 port_close (SCHEME_A_ a, port_input | port_output);
1569
1570 free (port (a));
1571 }
1572#endif
1573}
1529 1574
1530/*-- 1575/*--
1531 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1576 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1532 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1577 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1533 * for marking. 1578 * for marking.
1534 * 1579 *
1535 * The exception is vectors - vectors are currently marked recursively, 1580 * The exception is vectors - vectors are currently marked recursively,
1536 * which is inherited form tinyscheme and could be fixed by having another 1581 * which is inherited form tinyscheme and could be fixed by having another
1537 * word of context in the vector 1582 * word of context in the vector
1538 */ 1583 */
1539static void 1584ecb_hot static void
1540mark (pointer a) 1585mark (pointer a)
1541{ 1586{
1542 pointer t, q, p; 1587 pointer t, q, p;
1543 1588
1544 t = 0; 1589 t = 0;
… …
1601 p = q; 1646 p = q;
1602 goto E6; 1647 goto E6;
1603 } 1648 }
1604} 1649}
1605 1650
1651ecb_hot static void
1652gc_free (SCHEME_P)
1653{
1654 int i;
1655 uint32_t total = 0;
1656
1657 /* Here we scan the cells to build the free-list. */
1658 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1659 {
1660 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1661 struct cell *p;
1662 total += SCHEME_V->cell_segsize [i];
1663
1664 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1665 {
1666 pointer c = POINTER (p);
1667
1668 if (is_mark (c))
1669 clrmark (c);
1670 else
1671 {
1672 /* reclaim cell */
1673 if (typeflag (c) != T_PAIR)
1674 {
1675 finalize_cell (SCHEME_A_ c);
1676 set_typeflag (c, T_PAIR);
1677 set_car (c, NIL);
1678 }
1679
1680 ++SCHEME_V->fcells;
1681 set_cdr (c, SCHEME_V->free_cell);
1682 SCHEME_V->free_cell = c;
1683 }
1684 }
1685 }
1686
1687 if (SCHEME_V->gc_verbose)
1688 {
1689 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");
1690 }
1691}
1692
1606/* garbage collection. parameter a, b is marked. */ 1693/* garbage collection. parameter a, b is marked. */
1607static void 1694ecb_cold static void
1608gc (SCHEME_P_ pointer a, pointer b) 1695gc (SCHEME_P_ pointer a, pointer b)
1609{ 1696{
1610 pointer p;
1611 int i; 1697 int i;
1612 1698
1613 if (SCHEME_V->gc_verbose) 1699 if (SCHEME_V->gc_verbose)
1614 putstr (SCHEME_A_ "gc..."); 1700 putstr (SCHEME_A_ "gc...");
1615 1701
… …
1631 /* Mark recent objects the interpreter doesn't know about yet. */ 1717 /* Mark recent objects the interpreter doesn't know about yet. */
1632 mark (car (S_SINK)); 1718 mark (car (S_SINK));
1633 /* Mark any older stuff above nested C calls */ 1719 /* Mark any older stuff above nested C calls */
1634 mark (SCHEME_V->c_nest); 1720 mark (SCHEME_V->c_nest);
1635 1721
1722#if USE_INTCACHE
1723 /* mark intcache */
1724 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1725 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1726 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1727#endif
1728
1636 /* mark variables a, b */ 1729 /* mark variables a, b */
1637 mark (a); 1730 mark (a);
1638 mark (b); 1731 mark (b);
1639 1732
1640 /* garbage collect */ 1733 /* garbage collect */
1641 clrmark (NIL); 1734 clrmark (NIL);
1642 SCHEME_V->fcells = 0; 1735 SCHEME_V->fcells = 0;
1643 SCHEME_V->free_cell = NIL; 1736 SCHEME_V->free_cell = NIL;
1644 1737
1645 /* free-list is kept sorted by address so as to maintain consecutive
1646 ranges, if possible, for use with vectors. Here we scan the cells
1647 (which are also kept sorted by address) downwards to build the
1648 free-list in sorted order.
1649 */
1650 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1651 {
1652 p = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1653
1654 while (--p >= SCHEME_V->cell_seg[i])
1655 {
1656 if (is_mark (p))
1657 clrmark (p);
1658 else
1659 {
1660 /* reclaim cell */
1661 if (typeflag (p) != T_PAIR)
1662 {
1663 finalize_cell (SCHEME_A_ p);
1664 set_typeflag (p, T_PAIR);
1665 set_car (p, NIL);
1666 }
1667
1668 ++SCHEME_V->fcells;
1669 set_cdr (p, SCHEME_V->free_cell);
1670 SCHEME_V->free_cell = p;
1671 }
1672 }
1673 }
1674
1675 if (SCHEME_V->gc_verbose) 1738 if (SCHEME_V->gc_verbose)
1676 { 1739 putstr (SCHEME_A_ "freeing...");
1677 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" cells were recovered.\n");
1678 }
1679}
1680 1740
1681static void 1741 gc_free (SCHEME_A);
1682finalize_cell (SCHEME_P_ pointer a)
1683{
1684 /* TODO, fast bitmap check? */
1685 if (is_string (a))
1686 free (strvalue (a));
1687 else if (is_vector (a))
1688 free (vecvalue (a));
1689#if USE_PORTS
1690 else if (is_port (a))
1691 {
1692 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1693 port_close (SCHEME_A_ a, port_input | port_output);
1694
1695 free (a->object.port);
1696 }
1697#endif
1698} 1742}
1699 1743
1700/* ========== Routines for Reading ========== */ 1744/* ========== Routines for Reading ========== */
1701 1745
1702static int 1746ecb_cold static int
1703file_push (SCHEME_P_ const char *fname) 1747file_push (SCHEME_P_ const char *fname)
1704{ 1748{
1705#if USE_PORTS
1706 int fin; 1749 int fin;
1707 1750
1708 if (SCHEME_V->file_i == MAXFIL - 1) 1751 if (SCHEME_V->file_i == MAXFIL - 1)
1709 return 0; 1752 return 0;
1710 1753
… …
1716 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1759 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1717 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1760 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1718 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; 1761 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1719 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; 1762 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1720 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1763 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1721 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1764 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1722 1765
1723#if SHOW_ERROR_LINE 1766#if SHOW_ERROR_LINE
1724 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1767 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1725 1768
1726 if (fname) 1769 if (fname)
1727 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0); 1770 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1728#endif 1771#endif
1729 } 1772 }
1730 1773
1731 return fin >= 0; 1774 return fin >= 0;
1732
1733#else
1734 return 1;
1735#endif
1736} 1775}
1737 1776
1738static void 1777ecb_cold static void
1739file_pop (SCHEME_P) 1778file_pop (SCHEME_P)
1740{ 1779{
1741 if (SCHEME_V->file_i != 0) 1780 if (SCHEME_V->file_i != 0)
1742 { 1781 {
1743 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1782 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1744#if USE_PORTS 1783#if USE_PORTS
1745 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1784 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1746#endif 1785#endif
1747 SCHEME_V->file_i--; 1786 SCHEME_V->file_i--;
1748 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1787 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1749 } 1788 }
1750} 1789}
1751 1790
1752static int 1791ecb_cold static int
1753file_interactive (SCHEME_P) 1792file_interactive (SCHEME_P)
1754{ 1793{
1755#if USE_PORTS 1794#if USE_PORTS
1756 return SCHEME_V->file_i == 0 1795 return SCHEME_V->file_i == 0
1757 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1796 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1758 && (SCHEME_V->inport->object.port->kind & port_file); 1797 && (port (SCHEME_V->inport)->kind & port_file);
1759#else 1798#else
1760 return 0; 1799 return 0;
1761#endif 1800#endif
1762} 1801}
1763 1802
1764#if USE_PORTS 1803#if USE_PORTS
1765static port * 1804ecb_cold static port *
1766port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1805port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1767{ 1806{
1768 int fd; 1807 int fd;
1769 int flags; 1808 int flags;
1770 char *rw; 1809 char *rw;
… …
1793# endif 1832# endif
1794 1833
1795 return pt; 1834 return pt;
1796} 1835}
1797 1836
1798static pointer 1837ecb_cold static pointer
1799port_from_filename (SCHEME_P_ const char *fn, int prop) 1838port_from_filename (SCHEME_P_ const char *fn, int prop)
1800{ 1839{
1801 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1840 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1802 1841
1803 if (!pt && USE_ERROR_CHECKING) 1842 if (!pt && USE_ERROR_CHECKING)
1804 return NIL; 1843 return NIL;
1805 1844
1806 return mk_port (SCHEME_A_ pt); 1845 return mk_port (SCHEME_A_ pt);
1807} 1846}
1808 1847
1809static port * 1848ecb_cold static port *
1810port_rep_from_file (SCHEME_P_ int f, int prop) 1849port_rep_from_file (SCHEME_P_ int f, int prop)
1811{ 1850{
1812 port *pt = malloc (sizeof *pt); 1851 port *pt = malloc (sizeof *pt);
1813 1852
1814 if (!pt && USE_ERROR_CHECKING) 1853 if (!pt && USE_ERROR_CHECKING)
… …
1819 pt->rep.stdio.file = f; 1858 pt->rep.stdio.file = f;
1820 pt->rep.stdio.closeit = 0; 1859 pt->rep.stdio.closeit = 0;
1821 return pt; 1860 return pt;
1822} 1861}
1823 1862
1824static pointer 1863ecb_cold static pointer
1825port_from_file (SCHEME_P_ int f, int prop) 1864port_from_file (SCHEME_P_ int f, int prop)
1826{ 1865{
1827 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1866 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1828 1867
1829 if (!pt && USE_ERROR_CHECKING) 1868 if (!pt && USE_ERROR_CHECKING)
1830 return NIL; 1869 return NIL;
1831 1870
1832 return mk_port (SCHEME_A_ pt); 1871 return mk_port (SCHEME_A_ pt);
1833} 1872}
1834 1873
1835static port * 1874ecb_cold static port *
1836port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1875port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1837{ 1876{
1838 port *pt = malloc (sizeof (port)); 1877 port *pt = malloc (sizeof (port));
1839 1878
1840 if (!pt && USE_ERROR_CHECKING) 1879 if (!pt && USE_ERROR_CHECKING)
… …
1846 pt->rep.string.curr = start; 1885 pt->rep.string.curr = start;
1847 pt->rep.string.past_the_end = past_the_end; 1886 pt->rep.string.past_the_end = past_the_end;
1848 return pt; 1887 return pt;
1849} 1888}
1850 1889
1851static pointer 1890ecb_cold static pointer
1852port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1891port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1853{ 1892{
1854 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1893 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1855 1894
1856 if (!pt && USE_ERROR_CHECKING) 1895 if (!pt && USE_ERROR_CHECKING)
… …
1859 return mk_port (SCHEME_A_ pt); 1898 return mk_port (SCHEME_A_ pt);
1860} 1899}
1861 1900
1862# define BLOCK_SIZE 256 1901# define BLOCK_SIZE 256
1863 1902
1864static port * 1903ecb_cold static port *
1865port_rep_from_scratch (SCHEME_P) 1904port_rep_from_scratch (SCHEME_P)
1866{ 1905{
1867 char *start; 1906 char *start;
1868 port *pt = malloc (sizeof (port)); 1907 port *pt = malloc (sizeof (port));
1869 1908
… …
1883 pt->rep.string.curr = start; 1922 pt->rep.string.curr = start;
1884 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1923 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1885 return pt; 1924 return pt;
1886} 1925}
1887 1926
1888static pointer 1927ecb_cold static pointer
1889port_from_scratch (SCHEME_P) 1928port_from_scratch (SCHEME_P)
1890{ 1929{
1891 port *pt = port_rep_from_scratch (SCHEME_A); 1930 port *pt = port_rep_from_scratch (SCHEME_A);
1892 1931
1893 if (!pt && USE_ERROR_CHECKING) 1932 if (!pt && USE_ERROR_CHECKING)
1894 return NIL; 1933 return NIL;
1895 1934
1896 return mk_port (SCHEME_A_ pt); 1935 return mk_port (SCHEME_A_ pt);
1897} 1936}
1898 1937
1899static void 1938ecb_cold static void
1900port_close (SCHEME_P_ pointer p, int flag) 1939port_close (SCHEME_P_ pointer p, int flag)
1901{ 1940{
1902 port *pt = p->object.port; 1941 port *pt = port (p);
1903 1942
1904 pt->kind &= ~flag; 1943 pt->kind &= ~flag;
1905 1944
1906 if ((pt->kind & (port_input | port_output)) == 0) 1945 if ((pt->kind & (port_input | port_output)) == 0)
1907 { 1946 {
… …
1924 } 1963 }
1925} 1964}
1926#endif 1965#endif
1927 1966
1928/* get new character from input file */ 1967/* get new character from input file */
1929static int 1968ecb_cold static int
1930inchar (SCHEME_P) 1969inchar (SCHEME_P)
1931{ 1970{
1932 int c; 1971 int c;
1933 port *pt; 1972 port *pt = port (SCHEME_V->inport);
1934
1935 pt = SCHEME_V->inport->object.port;
1936 1973
1937 if (pt->kind & port_saw_EOF) 1974 if (pt->kind & port_saw_EOF)
1938 return EOF; 1975 return EOF;
1939 1976
1940 c = basic_inchar (pt); 1977 c = basic_inchar (pt);
… …
1950 } 1987 }
1951 1988
1952 return c; 1989 return c;
1953} 1990}
1954 1991
1955static int ungot = -1; 1992ecb_cold static int
1956
1957static int
1958basic_inchar (port *pt) 1993basic_inchar (port *pt)
1959{ 1994{
1960#if USE_PORTS
1961 if (pt->unget != -1) 1995 if (pt->unget != -1)
1962 { 1996 {
1963 int r = pt->unget; 1997 int r = pt->unget;
1964 pt->unget = -1; 1998 pt->unget = -1;
1965 return r; 1999 return r;
1966 } 2000 }
1967 2001
2002#if USE_PORTS
1968 if (pt->kind & port_file) 2003 if (pt->kind & port_file)
1969 { 2004 {
1970 char c; 2005 char c;
1971 2006
1972 if (!read (pt->rep.stdio.file, &c, 1)) 2007 if (!read (pt->rep.stdio.file, &c, 1))
… …
1980 return EOF; 2015 return EOF;
1981 else 2016 else
1982 return *pt->rep.string.curr++; 2017 return *pt->rep.string.curr++;
1983 } 2018 }
1984#else 2019#else
1985 if (ungot == -1)
1986 {
1987 char c; 2020 char c;
1988 if (!read (0, &c, 1)) 2021
2022 if (!read (pt->rep.stdio.file, &c, 1))
1989 return EOF; 2023 return EOF;
1990 2024
1991 ungot = c;
1992 }
1993
1994 {
1995 int r = ungot;
1996 ungot = -1;
1997 return r; 2025 return c;
1998 }
1999#endif 2026#endif
2000} 2027}
2001 2028
2002/* back character to input buffer */ 2029/* back character to input buffer */
2003static void 2030ecb_cold static void
2004backchar (SCHEME_P_ int c) 2031backchar (SCHEME_P_ int c)
2005{ 2032{
2006#if USE_PORTS 2033 port *pt = port (SCHEME_V->inport);
2007 port *pt;
2008 2034
2009 if (c == EOF) 2035 if (c == EOF)
2010 return; 2036 return;
2011 2037
2012 pt = SCHEME_V->inport->object.port;
2013 pt->unget = c; 2038 pt->unget = c;
2014#else
2015 if (c == EOF)
2016 return;
2017
2018 ungot = c;
2019#endif
2020} 2039}
2021 2040
2022#if USE_PORTS 2041#if USE_PORTS
2023static int 2042ecb_cold static int
2024realloc_port_string (SCHEME_P_ port *p) 2043realloc_port_string (SCHEME_P_ port *p)
2025{ 2044{
2026 char *start = p->rep.string.start; 2045 char *start = p->rep.string.start;
2027 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2046 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2028 char *str = malloc (new_size); 2047 char *str = malloc (new_size);
… …
2041 else 2060 else
2042 return 0; 2061 return 0;
2043} 2062}
2044#endif 2063#endif
2045 2064
2046INTERFACE void 2065ecb_cold static void
2047putstr (SCHEME_P_ const char *s) 2066putchars (SCHEME_P_ const char *s, int len)
2048{ 2067{
2068 port *pt = port (SCHEME_V->outport);
2069
2049#if USE_PORTS 2070#if USE_PORTS
2050 port *pt = SCHEME_V->outport->object.port;
2051
2052 if (pt->kind & port_file)
2053 write (pt->rep.stdio.file, s, strlen (s));
2054 else
2055 for (; *s; s++)
2056 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2057 *pt->rep.string.curr++ = *s;
2058 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2059 *pt->rep.string.curr++ = *s;
2060
2061#else
2062 xwrstr (s);
2063#endif
2064}
2065
2066static void
2067putchars (SCHEME_P_ const char *s, int len)
2068{
2069#if USE_PORTS
2070 port *pt = SCHEME_V->outport->object.port;
2071
2072 if (pt->kind & port_file) 2071 if (pt->kind & port_file)
2073 write (pt->rep.stdio.file, s, len); 2072 write (pt->rep.stdio.file, s, len);
2074 else 2073 else
2075 { 2074 {
2076 for (; len; len--) 2075 for (; len; len--)
… …
2081 *pt->rep.string.curr++ = *s++; 2080 *pt->rep.string.curr++ = *s++;
2082 } 2081 }
2083 } 2082 }
2084 2083
2085#else 2084#else
2086 write (1, s, len); 2085 write (1, s, len); // output not initialised
2087#endif 2086#endif
2087}
2088
2089INTERFACE void
2090putstr (SCHEME_P_ const char *s)
2091{
2092 putchars (SCHEME_A_ s, strlen (s));
2088} 2093}
2089 2094
2090INTERFACE void 2095INTERFACE void
2091putcharacter (SCHEME_P_ int c) 2096putcharacter (SCHEME_P_ int c)
2092{ 2097{
2093#if USE_PORTS
2094 port *pt = SCHEME_V->outport->object.port;
2095
2096 if (pt->kind & port_file)
2097 {
2098 char cc = c;
2099 write (pt->rep.stdio.file, &cc, 1);
2100 }
2101 else
2102 {
2103 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2104 *pt->rep.string.curr++ = c;
2105 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2106 *pt->rep.string.curr++ = c;
2107 }
2108
2109#else
2110 char cc = c; 2098 char cc = c;
2111 write (1, &c, 1); 2099
2112#endif 2100 putchars (SCHEME_A_ &cc, 1);
2113} 2101}
2114 2102
2115/* read characters up to delimiter, but cater to character constants */ 2103/* read characters up to delimiter, but cater to character constants */
2116static char * 2104ecb_cold static char *
2117readstr_upto (SCHEME_P_ int skip, const char *delim) 2105readstr_upto (SCHEME_P_ int skip, const char *delim)
2118{ 2106{
2119 char *p = SCHEME_V->strbuff + skip; 2107 char *p = SCHEME_V->strbuff + skip;
2120 2108
2121 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2109 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
… …
2130 2118
2131 return SCHEME_V->strbuff; 2119 return SCHEME_V->strbuff;
2132} 2120}
2133 2121
2134/* read string expression "xxx...xxx" */ 2122/* read string expression "xxx...xxx" */
2135static pointer 2123ecb_cold static pointer
2136readstrexp (SCHEME_P_ char delim) 2124readstrexp (SCHEME_P_ char delim)
2137{ 2125{
2138 char *p = SCHEME_V->strbuff; 2126 char *p = SCHEME_V->strbuff;
2139 int c; 2127 int c;
2140 int c1 = 0; 2128 int c1 = 0;
… …
2173 case '7': 2161 case '7':
2174 state = st_oct1; 2162 state = st_oct1;
2175 c1 = c - '0'; 2163 c1 = c - '0';
2176 break; 2164 break;
2177 2165
2166 case 'a': *p++ = '\a'; state = st_ok; break;
2167 case 'n': *p++ = '\n'; state = st_ok; break;
2168 case 'r': *p++ = '\r'; state = st_ok; break;
2169 case 't': *p++ = '\t'; state = st_ok; break;
2170
2171 // this overshoots the minimum requirements of r7rs
2172 case ' ':
2173 case '\t':
2174 case '\r':
2175 case '\n':
2176 skipspace (SCHEME_A);
2177 state = st_ok;
2178 break;
2179
2180 //TODO: x should end in ;, not two-digit hex
2178 case 'x': 2181 case 'x':
2179 case 'X': 2182 case 'X':
2180 state = st_x1; 2183 state = st_x1;
2181 c1 = 0; 2184 c1 = 0;
2182 break;
2183
2184 case 'n':
2185 *p++ = '\n';
2186 state = st_ok;
2187 break;
2188
2189 case 't':
2190 *p++ = '\t';
2191 state = st_ok;
2192 break;
2193
2194 case 'r':
2195 *p++ = '\r';
2196 state = st_ok;
2197 break; 2185 break;
2198 2186
2199 default: 2187 default:
2200 *p++ = c; 2188 *p++ = c;
2201 state = st_ok; 2189 state = st_ok;
… …
2253 } 2241 }
2254 } 2242 }
2255} 2243}
2256 2244
2257/* check c is in chars */ 2245/* check c is in chars */
2258ecb_inline int 2246ecb_cold int
2259is_one_of (const char *s, int c) 2247is_one_of (const char *s, int c)
2260{ 2248{
2261 if (c == EOF)
2262 return 1;
2263
2264 return !!strchr (s, c); 2249 return c == EOF || !!strchr (s, c);
2265} 2250}
2266 2251
2267/* skip white characters */ 2252/* skip white characters */
2268ecb_inline int 2253ecb_cold int
2269skipspace (SCHEME_P) 2254skipspace (SCHEME_P)
2270{ 2255{
2271 int c, curr_line = 0; 2256 int c, curr_line = 0;
2272 2257
2273 do 2258 do
2274 { 2259 {
2275 c = inchar (SCHEME_A); 2260 c = inchar (SCHEME_A);
2261
2276#if SHOW_ERROR_LINE 2262#if SHOW_ERROR_LINE
2277 if (c == '\n') 2263 if (ecb_expect_false (c == '\n'))
2278 curr_line++; 2264 curr_line++;
2279#endif 2265#endif
2266
2267 if (ecb_expect_false (c == EOF))
2268 return c;
2280 } 2269 }
2281 while (c == ' ' || c == '\n' || c == '\r' || c == '\t'); 2270 while (is_one_of (WHITESPACE, c));
2282 2271
2283 /* record it */ 2272 /* record it */
2284#if SHOW_ERROR_LINE 2273#if SHOW_ERROR_LINE
2285 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file) 2274 if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
2286 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line; 2275 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
2287#endif 2276#endif
2288 2277
2289 if (c != EOF)
2290 {
2291 backchar (SCHEME_A_ c); 2278 backchar (SCHEME_A_ c);
2292 return 1; 2279 return 1;
2293 }
2294 else
2295 return EOF;
2296} 2280}
2297 2281
2298/* get token */ 2282/* get token */
2299static int 2283ecb_cold static int
2300token (SCHEME_P) 2284token (SCHEME_P)
2301{ 2285{
2302 int c = skipspace (SCHEME_A); 2286 int c = skipspace (SCHEME_A);
2303 2287
2304 if (c == EOF) 2288 if (c == EOF)
… …
2316 return TOK_RPAREN; 2300 return TOK_RPAREN;
2317 2301
2318 case '.': 2302 case '.':
2319 c = inchar (SCHEME_A); 2303 c = inchar (SCHEME_A);
2320 2304
2321 if (is_one_of (" \n\t", c)) 2305 if (is_one_of (WHITESPACE, c))
2322 return TOK_DOT; 2306 return TOK_DOT;
2323 else 2307 else
2324 { 2308 {
2325 backchar (SCHEME_A_ c); 2309 backchar (SCHEME_A_ c);
2326 return TOK_DOTATOM; 2310 return TOK_DOTATOM;
… …
2402} 2386}
2403 2387
2404/* ========== Routines for Printing ========== */ 2388/* ========== Routines for Printing ========== */
2405#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2389#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2406 2390
2407static void 2391ecb_cold static void
2408printslashstring (SCHEME_P_ char *p, int len) 2392printslashstring (SCHEME_P_ char *p, int len)
2409{ 2393{
2410 int i; 2394 int i;
2411 unsigned char *s = (unsigned char *) p; 2395 unsigned char *s = (unsigned char *) p;
2412 2396
… …
2467 } 2451 }
2468 2452
2469 putcharacter (SCHEME_A_ '"'); 2453 putcharacter (SCHEME_A_ '"');
2470} 2454}
2471 2455
2472
2473/* print atoms */ 2456/* print atoms */
2474static void 2457ecb_cold static void
2475printatom (SCHEME_P_ pointer l, int f) 2458printatom (SCHEME_P_ pointer l, int f)
2476{ 2459{
2477 char *p; 2460 char *p;
2478 int len; 2461 int len;
2479 2462
2480 atom2str (SCHEME_A_ l, f, &p, &len); 2463 atom2str (SCHEME_A_ l, f, &p, &len);
2481 putchars (SCHEME_A_ p, len); 2464 putchars (SCHEME_A_ p, len);
2482} 2465}
2483 2466
2484
2485/* Uses internal buffer unless string pointer is already available */ 2467/* Uses internal buffer unless string pointer is already available */
2486static void 2468ecb_cold static void
2487atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2469atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2488{ 2470{
2489 char *p; 2471 char *p;
2490 2472
2491 if (l == NIL) 2473 if (l == NIL)
… …
2649#endif 2631#endif
2650 } 2632 }
2651 else if (is_continuation (l)) 2633 else if (is_continuation (l))
2652 p = "#<CONTINUATION>"; 2634 p = "#<CONTINUATION>";
2653 else 2635 else
2636 {
2637#if USE_PRINTF
2638 p = SCHEME_V->strbuff;
2639 snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
2640#else
2654 p = "#<ERROR>"; 2641 p = "#<ERROR>";
2642#endif
2643 }
2655 2644
2656 *pp = p; 2645 *pp = p;
2657 *plen = strlen (p); 2646 *plen = strlen (p);
2658} 2647}
2659 2648
… …
2691 return car (d); 2680 return car (d);
2692 2681
2693 p = cons (car (d), cdr (d)); 2682 p = cons (car (d), cdr (d));
2694 q = p; 2683 q = p;
2695 2684
2696 while (cdr (cdr (p)) != NIL) 2685 while (cddr (p) != NIL)
2697 { 2686 {
2698 d = cons (car (p), cdr (p)); 2687 d = cons (car (p), cdr (p));
2699 2688
2700 if (cdr (cdr (p)) != NIL) 2689 if (cddr (p) != NIL)
2701 p = cdr (d); 2690 p = cdr (d);
2702 } 2691 }
2703 2692
2704 set_cdr (p, car (cdr (p))); 2693 set_cdr (p, cadr (p));
2705 return q; 2694 return q;
2706} 2695}
2707 2696
2708/* reverse list -- produce new list */ 2697/* reverse list -- produce new list */
2709static pointer 2698ecb_hot static pointer
2710reverse (SCHEME_P_ pointer a) 2699reverse (SCHEME_P_ pointer a)
2711{ 2700{
2712 /* a must be checked by gc */ 2701 /* a must be checked by gc */
2713 pointer p = NIL; 2702 pointer p = NIL;
2714 2703
… …
2717 2706
2718 return p; 2707 return p;
2719} 2708}
2720 2709
2721/* reverse list --- in-place */ 2710/* reverse list --- in-place */
2722static pointer 2711ecb_hot static pointer
2723reverse_in_place (SCHEME_P_ pointer term, pointer list) 2712reverse_in_place (SCHEME_P_ pointer term, pointer list)
2724{ 2713{
2725 pointer result = term; 2714 pointer result = term;
2726 pointer p = list; 2715 pointer p = list;
2727 2716
… …
2735 2724
2736 return result; 2725 return result;
2737} 2726}
2738 2727
2739/* append list -- produce new list (in reverse order) */ 2728/* append list -- produce new list (in reverse order) */
2740static pointer 2729ecb_hot static pointer
2741revappend (SCHEME_P_ pointer a, pointer b) 2730revappend (SCHEME_P_ pointer a, pointer b)
2742{ 2731{
2743 pointer result = a; 2732 pointer result = a;
2744 pointer p = b; 2733 pointer p = b;
2745 2734
… …
2754 2743
2755 return S_F; /* signal an error */ 2744 return S_F; /* signal an error */
2756} 2745}
2757 2746
2758/* equivalence of atoms */ 2747/* equivalence of atoms */
2759int 2748ecb_hot int
2760eqv (pointer a, pointer b) 2749eqv (pointer a, pointer b)
2761{ 2750{
2762 if (is_string (a)) 2751 if (is_string (a))
2763 { 2752 {
2764 if (is_string (b)) 2753 if (is_string (b))
… …
2858 } 2847 }
2859 else 2848 else
2860 set_car (env, immutable_cons (slot, car (env))); 2849 set_car (env, immutable_cons (slot, car (env)));
2861} 2850}
2862 2851
2863static pointer 2852ecb_hot static pointer
2864find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2853find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2865{ 2854{
2866 pointer x, y; 2855 pointer x, y;
2867 2856
2868 for (x = env; x != NIL; x = cdr (x)) 2857 for (x = env; x != NIL; x = cdr (x))
… …
2889 return NIL; 2878 return NIL;
2890} 2879}
2891 2880
2892#else /* USE_ALIST_ENV */ 2881#else /* USE_ALIST_ENV */
2893 2882
2894ecb_inline void 2883static void
2895new_frame_in_env (SCHEME_P_ pointer old_env) 2884new_frame_in_env (SCHEME_P_ pointer old_env)
2896{ 2885{
2897 SCHEME_V->envir = immutable_cons (NIL, old_env); 2886 SCHEME_V->envir = immutable_cons (NIL, old_env);
2898 setenvironment (SCHEME_V->envir); 2887 setenvironment (SCHEME_V->envir);
2899} 2888}
2900 2889
2901ecb_inline void 2890static void
2902new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2891new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2903{ 2892{
2904 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2893 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2905} 2894}
2906 2895
2907static pointer 2896ecb_hot static pointer
2908find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2897find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2909{ 2898{
2910 pointer x, y; 2899 pointer x, y;
2911 2900
2912 for (x = env; x != NIL; x = cdr (x)) 2901 for (x = env; x != NIL; x = cdr (x))
… …
2926 return NIL; 2915 return NIL;
2927} 2916}
2928 2917
2929#endif /* USE_ALIST_ENV else */ 2918#endif /* USE_ALIST_ENV else */
2930 2919
2931ecb_inline void 2920static void
2932new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2921new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2933{ 2922{
2923 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2934 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2924 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2935} 2925}
2936 2926
2937ecb_inline void 2927static void
2938set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2928set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2939{ 2929{
2940 set_cdr (slot, value); 2930 set_cdr (slot, value);
2941} 2931}
2942 2932
2943ecb_inline pointer 2933static pointer
2944slot_value_in_env (pointer slot) 2934slot_value_in_env (pointer slot)
2945{ 2935{
2946 return cdr (slot); 2936 return cdr (slot);
2947} 2937}
2948 2938
2949/* ========== Evaluation Cycle ========== */ 2939/* ========== Evaluation Cycle ========== */
2950 2940
2951static int 2941ecb_cold static int
2952xError_1 (SCHEME_P_ const char *s, pointer a) 2942xError_1 (SCHEME_P_ const char *s, pointer a)
2953{ 2943{
2954#if USE_ERROR_HOOK
2955 pointer x;
2956 pointer hdl = SCHEME_V->ERROR_HOOK;
2957#endif
2958
2959#if USE_PRINTF 2944#if USE_PRINTF
2960#if SHOW_ERROR_LINE 2945#if SHOW_ERROR_LINE
2961 char sbuf[STRBUFFSIZE]; 2946 char sbuf[STRBUFFSIZE];
2962 2947
2963 /* make sure error is not in REPL */ 2948 /* make sure error is not in REPL */
… …
2978 } 2963 }
2979#endif 2964#endif
2980#endif 2965#endif
2981 2966
2982#if USE_ERROR_HOOK 2967#if USE_ERROR_HOOK
2983 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 2968 pointer x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->ERROR_HOOK, 1);
2984 2969
2985 if (x != NIL) 2970 if (x != NIL)
2986 { 2971 {
2987 pointer code = a 2972 pointer code = a
2988 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL) 2973 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
… …
3032 pointer code; 3017 pointer code;
3033}; 3018};
3034 3019
3035# define STACK_GROWTH 3 3020# define STACK_GROWTH 3
3036 3021
3037static void 3022ecb_hot static void
3038s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3023s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3039{ 3024{
3040 int nframes = (uintptr_t)SCHEME_V->dump; 3025 int nframes = (uintptr_t)SCHEME_V->dump;
3041 struct dump_stack_frame *next_frame; 3026 struct dump_stack_frame *next_frame;
3042 3027
3043 /* enough room for the next frame? */ 3028 /* enough room for the next frame? */
3044 if (nframes >= SCHEME_V->dump_size) 3029 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3045 { 3030 {
3046 SCHEME_V->dump_size += STACK_GROWTH; 3031 SCHEME_V->dump_size += STACK_GROWTH;
3047 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); 3032 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3048 } 3033 }
3049 3034
… …
3055 next_frame->code = code; 3040 next_frame->code = code;
3056 3041
3057 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3042 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3058} 3043}
3059 3044
3060static int 3045static ecb_hot int
3061xs_return (SCHEME_P_ pointer a) 3046xs_return (SCHEME_P_ pointer a)
3062{ 3047{
3063 int nframes = (uintptr_t)SCHEME_V->dump; 3048 int nframes = (uintptr_t)SCHEME_V->dump;
3064 struct dump_stack_frame *frame; 3049 struct dump_stack_frame *frame;
3065 3050
… …
3076 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3061 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3077 3062
3078 return 0; 3063 return 0;
3079} 3064}
3080 3065
3081ecb_inline void 3066ecb_cold void
3082dump_stack_reset (SCHEME_P) 3067dump_stack_reset (SCHEME_P)
3083{ 3068{
3084 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3069 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3085 SCHEME_V->dump = (pointer)+0; 3070 SCHEME_V->dump = (pointer)+0;
3086} 3071}
3087 3072
3088ecb_inline void 3073ecb_cold void
3089dump_stack_initialize (SCHEME_P) 3074dump_stack_initialize (SCHEME_P)
3090{ 3075{
3091 SCHEME_V->dump_size = 0; 3076 SCHEME_V->dump_size = 0;
3092 SCHEME_V->dump_base = 0; 3077 SCHEME_V->dump_base = 0;
3093 dump_stack_reset (SCHEME_A); 3078 dump_stack_reset (SCHEME_A);
3094} 3079}
3095 3080
3096static void 3081ecb_cold static void
3097dump_stack_free (SCHEME_P) 3082dump_stack_free (SCHEME_P)
3098{ 3083{
3099 free (SCHEME_V->dump_base); 3084 free (SCHEME_V->dump_base);
3100 SCHEME_V->dump_base = 0; 3085 SCHEME_V->dump_base = 0;
3101 SCHEME_V->dump = (pointer)0; 3086 SCHEME_V->dump = (pointer)0;
3102 SCHEME_V->dump_size = 0; 3087 SCHEME_V->dump_size = 0;
3103} 3088}
3104 3089
3105static void 3090ecb_cold static void
3106dump_stack_mark (SCHEME_P) 3091dump_stack_mark (SCHEME_P)
3107{ 3092{
3108 int nframes = (uintptr_t)SCHEME_V->dump; 3093 int nframes = (uintptr_t)SCHEME_V->dump;
3109 int i; 3094 int i;
3110 3095
… …
3116 mark (frame->envir); 3101 mark (frame->envir);
3117 mark (frame->code); 3102 mark (frame->code);
3118 } 3103 }
3119} 3104}
3120 3105
3121static pointer 3106ecb_cold static pointer
3122ss_get_cont (SCHEME_P) 3107ss_get_cont (SCHEME_P)
3123{ 3108{
3124 int nframes = (uintptr_t)SCHEME_V->dump; 3109 int nframes = (uintptr_t)SCHEME_V->dump;
3125 int i; 3110 int i;
3126 3111
… …
3138 } 3123 }
3139 3124
3140 return cont; 3125 return cont;
3141} 3126}
3142 3127
3143static void 3128ecb_cold static void
3144ss_set_cont (SCHEME_P_ pointer cont) 3129ss_set_cont (SCHEME_P_ pointer cont)
3145{ 3130{
3146 int i = 0; 3131 int i = 0;
3147 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3132 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3148 3133
… …
3160 SCHEME_V->dump = (pointer)(uintptr_t)i; 3145 SCHEME_V->dump = (pointer)(uintptr_t)i;
3161} 3146}
3162 3147
3163#else 3148#else
3164 3149
3165ecb_inline void 3150ecb_cold void
3166dump_stack_reset (SCHEME_P) 3151dump_stack_reset (SCHEME_P)
3167{ 3152{
3168 SCHEME_V->dump = NIL; 3153 SCHEME_V->dump = NIL;
3169} 3154}
3170 3155
3171ecb_inline void 3156ecb_cold void
3172dump_stack_initialize (SCHEME_P) 3157dump_stack_initialize (SCHEME_P)
3173{ 3158{
3174 dump_stack_reset (SCHEME_A); 3159 dump_stack_reset (SCHEME_A);
3175} 3160}
3176 3161
3177static void 3162ecb_cold static void
3178dump_stack_free (SCHEME_P) 3163dump_stack_free (SCHEME_P)
3179{ 3164{
3180 SCHEME_V->dump = NIL; 3165 SCHEME_V->dump = NIL;
3181} 3166}
3182 3167
3183static int 3168ecb_hot static int
3184xs_return (SCHEME_P_ pointer a) 3169xs_return (SCHEME_P_ pointer a)
3185{ 3170{
3186 pointer dump = SCHEME_V->dump; 3171 pointer dump = SCHEME_V->dump;
3187 3172
3188 SCHEME_V->value = a; 3173 SCHEME_V->value = a;
… …
3198 SCHEME_V->dump = dump; 3183 SCHEME_V->dump = dump;
3199 3184
3200 return 0; 3185 return 0;
3201} 3186}
3202 3187
3203static void 3188ecb_hot static void
3204s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3189s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3205{ 3190{
3206 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3191 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3207 cons (args, 3192 cons (args,
3208 cons (SCHEME_V->envir, 3193 cons (SCHEME_V->envir,
3209 cons (code, 3194 cons (code,
3210 SCHEME_V->dump)))); 3195 SCHEME_V->dump))));
3211} 3196}
3212 3197
3198ecb_cold static void
3199dump_stack_mark (SCHEME_P)
3200{
3201 mark (SCHEME_V->dump);
3202}
3203
3204ecb_cold static pointer
3205ss_get_cont (SCHEME_P)
3206{
3207 return SCHEME_V->dump;
3208}
3209
3210ecb_cold static void
3211ss_set_cont (SCHEME_P_ pointer cont)
3212{
3213 SCHEME_V->dump = cont;
3214}
3215
3216#endif
3217
3218#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3219
3220#if EXPERIMENT
3221
3222static int
3223dtree (SCHEME_P_ int indent, pointer x)
3224{
3225 int c;
3226
3227 if (is_syntax (x))
3228 {
3229 printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
3230 return 8 + 8;
3231 }
3232
3233 if (x == NIL)
3234 {
3235 printf ("%*sNIL\n", indent, "");
3236 return 3;
3237 }
3238
3239 switch (type (x))
3240 {
3241 case T_INTEGER:
3242 printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
3243 return 32+8;
3244
3245 case T_SYMBOL:
3246 printf ("%*sS<%s>\n", indent, "", symname (x));
3247 return 24+8;
3248
3249 case T_CLOSURE:
3250 printf ("%*sS<%s>\n", indent, "", "closure");
3251 dtree (SCHEME_A_ indent + 3, cdr(x));
3252 return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3253
3254 case T_PAIR:
3255 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3256 c = dtree (SCHEME_A_ indent + 3, car (x));
3257 c += dtree (SCHEME_A_ indent + 3, cdr (x));
3258 return c + 1;
3259
3260 case T_PORT:
3261 printf ("%*sS<%s>\n", indent, "", "port");
3262 return 24+8;
3263
3264 case T_VECTOR:
3265 printf ("%*sS<%s>\n", indent, "", "vector");
3266 return 24+8;
3267
3268 case T_ENVIRONMENT:
3269 printf ("%*sS<%s>\n", indent, "", "environment");
3270 return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3271
3272 default:
3273 printf ("unhandled type %d\n", type (x));
3274 break;
3275 }
3276}
3277
3278#define DUMP(t) do { printf ("DUMP %s:%d\n", __FILE__, __LINE__); dtree (SCHEME_A_ 0, (t)); } while (0)
3279
3280typedef void *stream[1];
3281
3282#define stream_init() { 0 }
3283#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
3284#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
3285#define stream_free(s) free (s[0])
3286
3287ecb_cold static void
3288stream_put (stream s, uint8_t byte)
3289{
3290 uint32_t *sp = *s;
3291 uint32_t size = sizeof (uint32_t) * 2;
3292 uint32_t offs = size;
3293
3294 if (ecb_expect_true (sp))
3295 {
3296 offs = sp[0];
3297 size = sp[1];
3298 }
3299
3300 if (ecb_expect_false (offs == size))
3301 {
3302 size *= 2;
3303 sp = realloc (sp, size);
3304 *s = sp;
3305 sp[1] = size;
3306
3307 }
3308
3309 ((uint8_t *)sp)[offs++] = byte;
3310 sp[0] = offs;
3311}
3312
3313ecb_cold static void
3314stream_put_v (stream s, uint32_t v)
3315{
3316 while (v > 0x7f)
3317 {
3318 stream_put (s, v | 0x80);
3319 v >>= 7;
3320 }
3321
3322 stream_put (s, v);
3323}
3324
3325ecb_cold static void
3326stream_put_tv (stream s, int bop, uint32_t v)
3327{
3328 printf ("put tv %d %d\n", bop, v);//D
3329 stream_put (s, bop);
3330 stream_put_v (s, v);
3331}
3332
3333ecb_cold static void
3334stream_put_stream (stream s, stream o)
3335{
3336 uint32_t i;
3337
3338 for (i = 0; i < stream_size (o); ++i)
3339 stream_put (s, stream_data (o)[i]);
3340
3341 stream_free (o);
3342}
3343
3344// calculates a (preferably small) integer that makes it possible to find
3345// the symbol again. if pointers were offsets into a memory area... until
3346// then, we return segment number in the low bits, and offset in the high
3347// bits.
3348// also, this function must never return 0.
3349ecb_cold static uint32_t
3350symbol_id (SCHEME_P_ pointer sym)
3351{
3352 struct cell *p = CELL (sym);
3353 int i;
3354
3355 for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3356 if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3357 return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3358
3359 abort ();
3360}
3361
3362ecb_cold static uint32_t
3363cell_id (SCHEME_P_ pointer p)
3364{
3365 return symbol_id (SCHEME_A_ p);
3366}
3367
3368enum byteop
3369{
3370 BOP_NIL,
3371 BOP_SYNTAX,
3372 BOP_INTEGER,
3373 BOP_SYMBOL,
3374 BOP_LIST_BEG,
3375 BOP_LIST_END,
3376 BOP_BIFT, // branch if true
3377 BOP_BIFF, // branch if false
3378 BOP_BIFNE, // branch if not eqv?
3379 BOP_BRA, // "short" branch
3380 BOP_JMP, // "long" jump
3381 BOP_DATUM,
3382 BOP_LET,
3383 BOP_LETAST,
3384 BOP_LETREC,
3385 BOP_DEFINE,
3386 BOP_MACRO,
3387 BOP_SET,
3388 BOP_BEGIN,
3389 BOP_LAMBDA,
3390};
3391
3392ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
3393
3394ecb_cold static void
3395compile_list (SCHEME_P_ stream s, pointer x)
3396{
3397 for (; x != NIL; x = cdr (x))
3398 compile_expr (SCHEME_A_ s, car (x));
3399}
3400
3213static void 3401static void
3214dump_stack_mark (SCHEME_P) 3402compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
3215{ 3403{
3216 mark (SCHEME_V->dump); 3404 //TODO: borked
3217} 3405 stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
3218 3406
3219static pointer 3407 stream_put (s, BOP_BIFF);
3220ss_get_cont (SCHEME_P) 3408 compile_expr (SCHEME_A_ s, cond);
3409 stream_put_v (s, stream_size (sift));
3410 stream_put_stream (s, sift);
3411
3412 if (iff != NIL)
3413 {
3414 stream siff = stream_init (); compile_expr (SCHEME_A_ siff, iff);
3415 stream_put_tv (s, BOP_BRA, stream_size (siff));
3416 stream_put_stream (s, siff);
3417 }
3418}
3419
3420typedef uint32_t stream_fixup;
3421
3422static stream_fixup
3423stream_put_fixup (stream s)
3221{ 3424{
3222 return SCHEME_V->dump; 3425 stream_put (s, 0);
3426 stream_put (s, 0);
3427
3428 return stream_size (s);
3223} 3429}
3224 3430
3225static void 3431static void
3226ss_set_cont (SCHEME_P_ pointer cont) 3432stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target)
3227{ 3433{
3228 SCHEME_V->dump = cont; 3434 target -= fixup;
3435 assert (target < (1 << 14));
3436 stream_data (s)[fixup - 2] = target | 0x80;
3437 stream_data (s)[fixup - 1] = target >> 7;
3229} 3438}
3230 3439
3231#endif
3232
3233#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3234
3235static int 3440static void
3441compile_and_or (SCHEME_P_ stream s, int and, pointer x)
3442{
3443 if (cdr (x) == NIL)
3444 compile_expr (SCHEME_A_ s, car (x));
3445 else
3446 {
3447 stream_put (s, and ? BOP_BIFF : BOP_BIFT);
3448 compile_expr (SCHEME_A_ s, car (x));
3449 stream_fixup end = stream_put_fixup (s);
3450
3451 compile_and_or (SCHEME_A_ s, and, cdr (x));
3452 stream_fix_fixup (s, end, stream_size (s));
3453 }
3454}
3455
3456ecb_cold static void
3457compile_expr (SCHEME_P_ stream s, pointer x)
3458{
3459 if (x == NIL)
3460 {
3461 stream_put (s, BOP_NIL);
3462 return;
3463 }
3464
3465 if (is_pair (x))
3466 {
3467 pointer head = car (x);
3468
3469 if (is_syntax (head))
3470 {
3471 x = cdr (x);
3472
3473 switch (syntaxnum (head))
3474 {
3475 case OP_IF0: /* if */
3476 compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
3477 break;
3478
3479 case OP_OR0: /* or */
3480 compile_and_or (SCHEME_A_ s, 0, x);
3481 break;
3482
3483 case OP_AND0: /* and */
3484 compile_and_or (SCHEME_A_ s, 1, x);
3485 break;
3486
3487 case OP_CASE0: /* case */
3488 abort ();
3489 break;
3490
3491 case OP_COND0: /* cond */
3492 abort ();
3493 break;
3494
3495 case OP_LET0: /* let */
3496 case OP_LET0AST: /* let* */
3497 case OP_LET0REC: /* letrec */
3498 switch (syntaxnum (head))
3499 {
3500 case OP_LET0: stream_put (s, BOP_LET ); break;
3501 case OP_LET0AST: stream_put (s, BOP_LETAST); break;
3502 case OP_LET0REC: stream_put (s, BOP_LETREC); break;
3503 }
3504
3505 {
3506 pointer bindings = car (x);
3507 pointer body = cadr (x);
3508
3509 for (x = bindings; x != NIL; x = cdr (x))
3510 {
3511 pointer init = NIL;
3512 pointer var = car (x);
3513
3514 if (is_pair (var))
3515 {
3516 init = cdr (var);
3517 var = car (var);
3518 }
3519
3520 stream_put_v (s, symbol_id (SCHEME_A_ var));
3521 compile_expr (SCHEME_A_ s, init);
3522 }
3523
3524 stream_put_v (s, 0);
3525 compile_expr (SCHEME_A_ s, body);
3526 }
3527 break;
3528
3529 case OP_DEF0: /* define */
3530 case OP_MACRO0: /* macro */
3531 stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO);
3532 stream_put_v (s, cell_id (SCHEME_A_ car (x)));
3533 compile_expr (SCHEME_A_ s, cadr (x));
3534 break;
3535
3536 case OP_SET0: /* set! */
3537 stream_put (s, BOP_SET);
3538 stream_put_v (s, symbol_id (SCHEME_A_ car (x)));
3539 compile_expr (SCHEME_A_ s, cadr (x));
3540 break;
3541
3542 case OP_BEGIN: /* begin */
3543 stream_put (s, BOP_BEGIN);
3544 compile_list (SCHEME_A_ s, x);
3545 return;
3546
3547 case OP_DELAY: /* delay */
3548 abort ();
3549 break;
3550
3551 case OP_QUOTE: /* quote */
3552 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3553 break;
3554
3555 case OP_LAMBDA: /* lambda */
3556 {
3557 pointer formals = car (x);
3558 pointer body = cadr (x);
3559
3560 stream_put (s, BOP_LAMBDA);
3561
3562 for (; is_pair (formals); formals = cdr (formals))
3563 stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
3564
3565 stream_put_v (s, 0);
3566 stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals));
3567
3568 compile_expr (SCHEME_A_ s, body);
3569 }
3570 break;
3571
3572 case OP_C0STREAM:/* cons-stream */
3573 abort ();
3574 break;
3575 }
3576
3577 return;
3578 }
3579
3580 pointer m = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, head, 1);
3581
3582 if (m != NIL)
3583 {
3584 m = slot_value_in_env (m);
3585
3586 if (is_macro (m))
3587 {
3588 s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
3589 SCHEME_V->code = m;
3590 SCHEME_V->args = cons (x, NIL);
3591 Eval_Cycle (SCHEME_A_ OP_APPLY);
3592 x = SCHEME_V->value;
3593 compile_expr (SCHEME_A_ s, SCHEME_V->value);
3594 return;
3595 }
3596 }
3597 }
3598
3599 switch (type (x))
3600 {
3601 case T_INTEGER:
3602 {
3603 IVALUE iv = ivalue_unchecked (x);
3604 iv = iv < 0 ? ((uint32_t)-iv << 1) | 1 : (uint32_t)iv << 1;
3605 stream_put_tv (s, BOP_INTEGER, iv);
3606 }
3607 return;
3608
3609 case T_SYMBOL:
3610 stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3611 return;
3612
3613 case T_PAIR:
3614 stream_put (s, BOP_LIST_BEG);
3615
3616 for (; x != NIL; x = cdr (x))
3617 compile_expr (SCHEME_A_ s, car (x));
3618
3619 stream_put (s, BOP_LIST_END);
3620 return;
3621
3622 default:
3623 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3624 break;
3625 }
3626}
3627
3628ecb_cold static int
3629compile_closure (SCHEME_P_ pointer p)
3630{
3631 stream s = stream_init ();
3632
3633 compile_list (SCHEME_A_ s, cdar (p));
3634
3635 FILE *xxd = popen ("xxd", "we");
3636 fwrite (stream_data (s), 1, stream_size (s), xxd);
3637 fclose (xxd);
3638
3639 return stream_size (s);
3640}
3641
3642#endif
3643
3644/* syntax, eval, core, ... */
3645ecb_hot static int
3236opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3646opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3237{ 3647{
3238 pointer args = SCHEME_V->args; 3648 pointer args = SCHEME_V->args;
3239 pointer x, y; 3649 pointer x, y;
3240 3650
3241 switch (op) 3651 switch (op)
3242 { 3652 {
3653#if EXPERIMENT //D
3654 case OP_DEBUG:
3655 {
3656 uint32_t len = compile_closure (SCHEME_A_ car (args));
3657 printf ("len = %d\n", len);
3658 printf ("\n");
3659 s_return (S_T);
3660 }
3661
3662 case OP_DEBUG2:
3663 return -1;
3664#endif
3665
3243 case OP_LOAD: /* load */ 3666 case OP_LOAD: /* load */
3244 if (file_interactive (SCHEME_A)) 3667 if (file_interactive (SCHEME_A))
3245 { 3668 {
3246 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3669 putstr (SCHEME_A_ "Loading ");
3247 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3670 putstr (SCHEME_A_ strvalue (car (args)));
3671 putcharacter (SCHEME_A_ '\n');
3248 } 3672 }
3249 3673
3250 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3674 if (!file_push (SCHEME_A_ strvalue (car (args))))
3251 Error_1 ("unable to open", car (args)); 3675 Error_1 ("unable to open", car (args));
3252 else 3676
3253 {
3254 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3677 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3255 s_goto (OP_T0LVL); 3678 s_goto (OP_T0LVL);
3256 }
3257 3679
3258 case OP_T0LVL: /* top level */ 3680 case OP_T0LVL: /* top level */
3259 3681
3260 /* If we reached the end of file, this loop is done. */ 3682 /* If we reached the end of file, this loop is done. */
3261 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3683 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3262 { 3684 {
3263 if (SCHEME_V->file_i == 0) 3685 if (SCHEME_V->file_i == 0)
3264 { 3686 {
3265 SCHEME_V->args = NIL; 3687 SCHEME_V->args = NIL;
3266 s_goto (OP_QUIT); 3688 s_goto (OP_QUIT);
… …
3277 /* If interactive, be nice to user. */ 3699 /* If interactive, be nice to user. */
3278 if (file_interactive (SCHEME_A)) 3700 if (file_interactive (SCHEME_A))
3279 { 3701 {
3280 SCHEME_V->envir = SCHEME_V->global_env; 3702 SCHEME_V->envir = SCHEME_V->global_env;
3281 dump_stack_reset (SCHEME_A); 3703 dump_stack_reset (SCHEME_A);
3282 putstr (SCHEME_A_ "\n"); 3704 putcharacter (SCHEME_A_ '\n');
3705#if EXPERIMENT
3706 system ("ps v $PPID");
3707#endif
3283 putstr (SCHEME_A_ prompt); 3708 putstr (SCHEME_A_ prompt);
3284 } 3709 }
3285 3710
3286 /* Set up another iteration of REPL */ 3711 /* Set up another iteration of REPL */
3287 SCHEME_V->nesting = 0; 3712 SCHEME_V->nesting = 0;
… …
3322 { 3747 {
3323 SCHEME_V->print_flag = 1; 3748 SCHEME_V->print_flag = 1;
3324 SCHEME_V->args = SCHEME_V->value; 3749 SCHEME_V->args = SCHEME_V->value;
3325 s_goto (OP_P0LIST); 3750 s_goto (OP_P0LIST);
3326 } 3751 }
3327 else 3752
3328 s_return (SCHEME_V->value); 3753 s_return (SCHEME_V->value);
3329 3754
3330 case OP_EVAL: /* main part of evaluation */ 3755 case OP_EVAL: /* main part of evaluation */
3331#if USE_TRACING 3756#if USE_TRACING
3332 if (SCHEME_V->tracing) 3757 if (SCHEME_V->tracing)
3333 { 3758 {
… …
3344#endif 3769#endif
3345 if (is_symbol (SCHEME_V->code)) /* symbol */ 3770 if (is_symbol (SCHEME_V->code)) /* symbol */
3346 { 3771 {
3347 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3772 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3348 3773
3349 if (x != NIL) 3774 if (x == NIL)
3350 s_return (slot_value_in_env (x));
3351 else
3352 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3775 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3776
3777 s_return (slot_value_in_env (x));
3353 } 3778 }
3354 else if (is_pair (SCHEME_V->code)) 3779 else if (is_pair (SCHEME_V->code))
3355 { 3780 {
3356 x = car (SCHEME_V->code); 3781 x = car (SCHEME_V->code);
3357 3782
… …
3366 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3791 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3367 SCHEME_V->code = x; 3792 SCHEME_V->code = x;
3368 s_goto (OP_EVAL); 3793 s_goto (OP_EVAL);
3369 } 3794 }
3370 } 3795 }
3371 else 3796
3372 s_return (SCHEME_V->code); 3797 s_return (SCHEME_V->code);
3373 3798
3374 case OP_E0ARGS: /* eval arguments */ 3799 case OP_E0ARGS: /* eval arguments */
3375 if (is_macro (SCHEME_V->value)) /* macro expansion */ 3800 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3376 { 3801 {
3377 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3802 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3378 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3803 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3379 SCHEME_V->code = SCHEME_V->value; 3804 SCHEME_V->code = SCHEME_V->value;
3380 s_goto (OP_APPLY); 3805 s_goto (OP_APPLY);
3381 } 3806 }
3382 else 3807
3383 {
3384 SCHEME_V->code = cdr (SCHEME_V->code); 3808 SCHEME_V->code = cdr (SCHEME_V->code);
3385 s_goto (OP_E1ARGS); 3809 s_goto (OP_E1ARGS);
3386 }
3387 3810
3388 case OP_E1ARGS: /* eval arguments */ 3811 case OP_E1ARGS: /* eval arguments */
3389 args = cons (SCHEME_V->value, args); 3812 args = cons (SCHEME_V->value, args);
3390 3813
3391 if (is_pair (SCHEME_V->code)) /* continue */ 3814 if (is_pair (SCHEME_V->code)) /* continue */
… …
3402 SCHEME_V->args = cdr (args); 3825 SCHEME_V->args = cdr (args);
3403 s_goto (OP_APPLY); 3826 s_goto (OP_APPLY);
3404 } 3827 }
3405 3828
3406#if USE_TRACING 3829#if USE_TRACING
3407
3408 case OP_TRACING: 3830 case OP_TRACING:
3409 { 3831 {
3410 int tr = SCHEME_V->tracing; 3832 int tr = SCHEME_V->tracing;
3411 3833
3412 SCHEME_V->tracing = ivalue_unchecked (car (args)); 3834 SCHEME_V->tracing = ivalue_unchecked (car (args));
3413 s_return (mk_integer (SCHEME_A_ tr)); 3835 s_return (mk_integer (SCHEME_A_ tr));
3414 } 3836 }
3415
3416#endif 3837#endif
3417 3838
3418 case OP_APPLY: /* apply 'code' to 'args' */ 3839 case OP_APPLY: /* apply 'code' to 'args' */
3419#if USE_TRACING 3840#if USE_TRACING
3420 if (SCHEME_V->tracing) 3841 if (SCHEME_V->tracing)
… …
3434 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3855 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3435 else if (is_foreign (SCHEME_V->code)) 3856 else if (is_foreign (SCHEME_V->code))
3436 { 3857 {
3437 /* Keep nested calls from GC'ing the arglist */ 3858 /* Keep nested calls from GC'ing the arglist */
3438 push_recent_alloc (SCHEME_A_ args, NIL); 3859 push_recent_alloc (SCHEME_A_ args, NIL);
3439 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3860 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3440 3861
3441 s_return (x); 3862 s_return (x);
3442 } 3863 }
3443 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3864 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3444 { 3865 {
… …
3474 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3895 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3475 { 3896 {
3476 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3897 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3477 s_return (args != NIL ? car (args) : NIL); 3898 s_return (args != NIL ? car (args) : NIL);
3478 } 3899 }
3479 else 3900
3480 Error_0 ("illegal function"); 3901 Error_0 ("illegal function");
3481 3902
3482 case OP_DOMACRO: /* do macro */ 3903 case OP_DOMACRO: /* do macro */
3483 SCHEME_V->code = SCHEME_V->value; 3904 SCHEME_V->code = SCHEME_V->value;
3484 s_goto (OP_EVAL); 3905 s_goto (OP_EVAL);
3485
3486#if 1
3487 3906
3488 case OP_LAMBDA: /* lambda */ 3907 case OP_LAMBDA: /* lambda */
3489 /* If the hook is defined, apply it to SCHEME_V->code, otherwise 3908 /* If the hook is defined, apply it to SCHEME_V->code, otherwise
3490 set SCHEME_V->value fall thru */ 3909 set SCHEME_V->value fall thru */
3491 { 3910 {
… …
3498 SCHEME_V->code = slot_value_in_env (f); 3917 SCHEME_V->code = slot_value_in_env (f);
3499 s_goto (OP_APPLY); 3918 s_goto (OP_APPLY);
3500 } 3919 }
3501 3920
3502 SCHEME_V->value = SCHEME_V->code; 3921 SCHEME_V->value = SCHEME_V->code;
3503 /* Fallthru */
3504 } 3922 }
3923 /* Fallthru */
3505 3924
3506 case OP_LAMBDA1: 3925 case OP_LAMBDA1:
3507 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir)); 3926 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));
3508
3509#else
3510
3511 case OP_LAMBDA: /* lambda */
3512 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3513
3514#endif
3515 3927
3516 case OP_MKCLOSURE: /* make-closure */ 3928 case OP_MKCLOSURE: /* make-closure */
3517 x = car (args); 3929 x = car (args);
3518 3930
3519 if (car (x) == SCHEME_V->LAMBDA) 3931 if (car (x) == SCHEME_V->LAMBDA)
… …
3558 else 3970 else
3559 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 3971 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3560 3972
3561 s_return (SCHEME_V->code); 3973 s_return (SCHEME_V->code);
3562 3974
3563
3564 case OP_DEFP: /* defined? */ 3975 case OP_DEFP: /* defined? */
3565 x = SCHEME_V->envir; 3976 x = SCHEME_V->envir;
3566 3977
3567 if (cdr (args) != NIL) 3978 if (cdr (args) != NIL)
3568 x = cadr (args); 3979 x = cadr (args);
… …
3586 s_return (SCHEME_V->value); 3997 s_return (SCHEME_V->value);
3587 } 3998 }
3588 else 3999 else
3589 Error_1 ("set!: unbound variable:", SCHEME_V->code); 4000 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3590 4001
3591
3592 case OP_BEGIN: /* begin */ 4002 case OP_BEGIN: /* begin */
3593 if (!is_pair (SCHEME_V->code)) 4003 if (!is_pair (SCHEME_V->code))
3594 s_return (SCHEME_V->code); 4004 s_return (SCHEME_V->code);
3595 4005
3596 if (cdr (SCHEME_V->code) != NIL) 4006 if (cdr (SCHEME_V->code) != NIL)
… …
3607 case OP_IF1: /* if */ 4017 case OP_IF1: /* if */
3608 if (is_true (SCHEME_V->value)) 4018 if (is_true (SCHEME_V->value))
3609 SCHEME_V->code = car (SCHEME_V->code); 4019 SCHEME_V->code = car (SCHEME_V->code);
3610 else 4020 else
3611 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ 4021 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
4022
3612 s_goto (OP_EVAL); 4023 s_goto (OP_EVAL);
3613 4024
3614 case OP_LET0: /* let */ 4025 case OP_LET0: /* let */
3615 SCHEME_V->args = NIL; 4026 SCHEME_V->args = NIL;
3616 SCHEME_V->value = SCHEME_V->code; 4027 SCHEME_V->value = SCHEME_V->code;
3617 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); 4028 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3618 s_goto (OP_LET1); 4029 s_goto (OP_LET1);
3619 4030
3620 case OP_LET1: /* let (calculate parameters) */ 4031 case OP_LET1: /* let (calculate parameters) */
4032 case OP_LET1REC: /* letrec (calculate parameters) */
3621 args = cons (SCHEME_V->value, args); 4033 args = cons (SCHEME_V->value, args);
3622 4034
3623 if (is_pair (SCHEME_V->code)) /* continue */ 4035 if (is_pair (SCHEME_V->code)) /* continue */
3624 { 4036 {
3625 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 4037 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3626 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); 4038 Error_1 ("Bad syntax of binding spec in let/letrec:", car (SCHEME_V->code));
3627 4039
3628 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); 4040 s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code));
3629 SCHEME_V->code = cadar (SCHEME_V->code); 4041 SCHEME_V->code = cadar (SCHEME_V->code);
3630 SCHEME_V->args = NIL; 4042 SCHEME_V->args = NIL;
3631 s_goto (OP_EVAL); 4043 s_goto (OP_EVAL);
3632 } 4044 }
3633 else /* end */ 4045
3634 { 4046 /* end */
3635 args = reverse_in_place (SCHEME_A_ NIL, args); 4047 args = reverse_in_place (SCHEME_A_ NIL, args);
3636 SCHEME_V->code = car (args); 4048 SCHEME_V->code = car (args);
3637 SCHEME_V->args = cdr (args); 4049 SCHEME_V->args = cdr (args);
3638 s_goto (OP_LET2); 4050 s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC);
3639 }
3640 4051
3641 case OP_LET2: /* let */ 4052 case OP_LET2: /* let */
3642 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4053 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3643 4054
3644 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 4055 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
… …
3648 if (is_symbol (car (SCHEME_V->code))) /* named let */ 4059 if (is_symbol (car (SCHEME_V->code))) /* named let */
3649 { 4060 {
3650 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 4061 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3651 { 4062 {
3652 if (!is_pair (x)) 4063 if (!is_pair (x))
3653 Error_1 ("Bad syntax of binding in let :", x); 4064 Error_1 ("Bad syntax of binding in let:", x);
3654 4065
3655 if (!is_list (SCHEME_A_ car (x))) 4066 if (!is_list (SCHEME_A_ car (x)))
3656 Error_1 ("Bad syntax of binding in let :", car (x)); 4067 Error_1 ("Bad syntax of binding in let:", car (x));
3657 4068
3658 args = cons (caar (x), args); 4069 args = cons (caar (x), args);
3659 } 4070 }
3660 4071
3661 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)), 4072 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
… …
3678 SCHEME_V->code = cdr (SCHEME_V->code); 4089 SCHEME_V->code = cdr (SCHEME_V->code);
3679 s_goto (OP_BEGIN); 4090 s_goto (OP_BEGIN);
3680 } 4091 }
3681 4092
3682 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code))) 4093 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code)))
3683 Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code)); 4094 Error_1 ("Bad syntax of binding spec in let*:", car (SCHEME_V->code));
3684 4095
3685 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code)); 4096 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
3686 SCHEME_V->code = car (cdaar (SCHEME_V->code)); 4097 SCHEME_V->code = car (cdaar (SCHEME_V->code));
3687 s_goto (OP_EVAL); 4098 s_goto (OP_EVAL);
3688 4099
… …
3699 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code); 4110 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3700 SCHEME_V->code = cadar (SCHEME_V->code); 4111 SCHEME_V->code = cadar (SCHEME_V->code);
3701 SCHEME_V->args = NIL; 4112 SCHEME_V->args = NIL;
3702 s_goto (OP_EVAL); 4113 s_goto (OP_EVAL);
3703 } 4114 }
3704 else /* end */ 4115
4116 /* end */
3705 { 4117
3706 SCHEME_V->code = args; 4118 SCHEME_V->code = args;
3707 SCHEME_V->args = NIL; 4119 SCHEME_V->args = NIL;
3708 s_goto (OP_BEGIN); 4120 s_goto (OP_BEGIN);
3709 }
3710 4121
3711 case OP_LET0REC: /* letrec */ 4122 case OP_LET0REC: /* letrec */
3712 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4123 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3713 SCHEME_V->args = NIL; 4124 SCHEME_V->args = NIL;
3714 SCHEME_V->value = SCHEME_V->code; 4125 SCHEME_V->value = SCHEME_V->code;
3715 SCHEME_V->code = car (SCHEME_V->code); 4126 SCHEME_V->code = car (SCHEME_V->code);
3716 s_goto (OP_LET1REC); 4127 s_goto (OP_LET1REC);
3717 4128
3718 case OP_LET1REC: /* letrec (calculate parameters) */ 4129 /* OP_LET1REC handled by OP_LET1 */
3719 args = cons (SCHEME_V->value, args);
3720
3721 if (is_pair (SCHEME_V->code)) /* continue */
3722 {
3723 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3724 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3725
3726 s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3727 SCHEME_V->code = cadar (SCHEME_V->code);
3728 SCHEME_V->args = NIL;
3729 s_goto (OP_EVAL);
3730 }
3731 else /* end */
3732 {
3733 args = reverse_in_place (SCHEME_A_ NIL, args);
3734 SCHEME_V->code = car (args);
3735 SCHEME_V->args = cdr (args);
3736 s_goto (OP_LET2REC);
3737 }
3738 4130
3739 case OP_LET2REC: /* letrec */ 4131 case OP_LET2REC: /* letrec */
3740 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) 4132 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3741 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 4133 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3742 4134
… …
3772 } 4164 }
3773 else 4165 else
3774 { 4166 {
3775 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) 4167 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3776 s_return (NIL); 4168 s_return (NIL);
3777 else 4169
3778 {
3779 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 4170 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3780 SCHEME_V->code = caar (SCHEME_V->code); 4171 SCHEME_V->code = caar (SCHEME_V->code);
3781 s_goto (OP_EVAL); 4172 s_goto (OP_EVAL);
3782 }
3783 } 4173 }
3784 4174
3785 case OP_DELAY: /* delay */ 4175 case OP_DELAY: /* delay */
3786 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 4176 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3787 set_typeflag (x, T_PROMISE); 4177 set_typeflag (x, T_PROMISE);
… …
3798 case OP_AND1: /* and */ 4188 case OP_AND1: /* and */
3799 if (is_false (SCHEME_V->value)) 4189 if (is_false (SCHEME_V->value))
3800 s_return (SCHEME_V->value); 4190 s_return (SCHEME_V->value);
3801 else if (SCHEME_V->code == NIL) 4191 else if (SCHEME_V->code == NIL)
3802 s_return (SCHEME_V->value); 4192 s_return (SCHEME_V->value);
3803 else 4193
3804 {
3805 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 4194 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3806 SCHEME_V->code = car (SCHEME_V->code); 4195 SCHEME_V->code = car (SCHEME_V->code);
3807 s_goto (OP_EVAL); 4196 s_goto (OP_EVAL);
3808 }
3809 4197
3810 case OP_OR0: /* or */ 4198 case OP_OR0: /* or */
3811 if (SCHEME_V->code == NIL) 4199 if (SCHEME_V->code == NIL)
3812 s_return (S_F); 4200 s_return (S_F);
3813 4201
… …
3818 case OP_OR1: /* or */ 4206 case OP_OR1: /* or */
3819 if (is_true (SCHEME_V->value)) 4207 if (is_true (SCHEME_V->value))
3820 s_return (SCHEME_V->value); 4208 s_return (SCHEME_V->value);
3821 else if (SCHEME_V->code == NIL) 4209 else if (SCHEME_V->code == NIL)
3822 s_return (SCHEME_V->value); 4210 s_return (SCHEME_V->value);
3823 else 4211
3824 {
3825 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 4212 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3826 SCHEME_V->code = car (SCHEME_V->code); 4213 SCHEME_V->code = car (SCHEME_V->code);
3827 s_goto (OP_EVAL); 4214 s_goto (OP_EVAL);
3828 }
3829 4215
3830 case OP_C0STREAM: /* cons-stream */ 4216 case OP_C0STREAM: /* cons-stream */
3831 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 4217 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3832 SCHEME_V->code = car (SCHEME_V->code); 4218 SCHEME_V->code = car (SCHEME_V->code);
3833 s_goto (OP_EVAL); 4219 s_goto (OP_EVAL);
… …
3898 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x)); 4284 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3899 SCHEME_V->code = caar (x); 4285 SCHEME_V->code = caar (x);
3900 s_goto (OP_EVAL); 4286 s_goto (OP_EVAL);
3901 } 4287 }
3902 } 4288 }
3903 else 4289
3904 s_return (NIL); 4290 s_return (NIL);
3905 4291
3906 case OP_CASE2: /* case */ 4292 case OP_CASE2: /* case */
3907 if (is_true (SCHEME_V->value)) 4293 if (is_true (SCHEME_V->value))
3908 s_goto (OP_BEGIN); 4294 s_goto (OP_BEGIN);
3909 else 4295
3910 s_return (NIL); 4296 s_return (NIL);
3911 4297
3912 case OP_PAPPLY: /* apply */ 4298 case OP_PAPPLY: /* apply */
3913 SCHEME_V->code = car (args); 4299 SCHEME_V->code = car (args);
3914 SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); 4300 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3915 /*SCHEME_V->args = cadr(args); */ 4301 /*SCHEME_V->args = cadr(args); */
… …
3929 } 4315 }
3930 4316
3931 if (USE_ERROR_CHECKING) abort (); 4317 if (USE_ERROR_CHECKING) abort ();
3932} 4318}
3933 4319
3934static int 4320/* math, cxr */
4321ecb_hot static int
3935opexe_1 (SCHEME_P_ enum scheme_opcodes op) 4322opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3936{ 4323{
3937 pointer args = SCHEME_V->args; 4324 pointer args = SCHEME_V->args;
3938 pointer x = car (args); 4325 pointer x = car (args);
3939 num v; 4326 num v;
3940 4327
3941 switch (op) 4328 switch (op)
3942 { 4329 {
3943#if USE_MATH 4330#if USE_MATH
3944 case OP_INEX2EX: /* inexact->exact */ 4331 case OP_INEX2EX: /* inexact->exact */
3945 {
3946 if (is_integer (x)) 4332 if (!is_integer (x))
3947 s_return (x); 4333 {
3948
3949 RVALUE r = rvalue_unchecked (x); 4334 RVALUE r = rvalue_unchecked (x);
3950 4335
3951 if (r == (RVALUE)(IVALUE)r) 4336 if (r == (RVALUE)(IVALUE)r)
3952 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4337 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
3953 else 4338 else
3954 Error_1 ("inexact->exact: not integral:", x); 4339 Error_1 ("inexact->exact: not integral:", x);
3955 } 4340 }
3956 4341
4342 s_return (x);
4343
4344 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4345 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4346 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4347 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4348
4349 case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
3957 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4350 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
3958 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4351 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4352 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
3959 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4353 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
3960 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4354 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
3961 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4355 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
3962 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4356 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
3963 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4357 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
3964 4358
3965 case OP_ATAN: 4359 case OP_ATAN:
4360 s_return (mk_real (SCHEME_A_
3966 if (cdr (args) == NIL) 4361 cdr (args) == NIL
3967 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4362 ? atan (rvalue (x))
3968 else 4363 : atan2 (rvalue (x), rvalue (cadr (args)))));
3969 {
3970 pointer y = cadr (args);
3971 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
3972 }
3973
3974 case OP_SQRT:
3975 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
3976 4364
3977 case OP_EXPT: 4365 case OP_EXPT:
3978 { 4366 {
3979 RVALUE result; 4367 RVALUE result;
3980 int real_result = 1; 4368 int real_result = 1;
… …
4003 if (real_result) 4391 if (real_result)
4004 s_return (mk_real (SCHEME_A_ result)); 4392 s_return (mk_real (SCHEME_A_ result));
4005 else 4393 else
4006 s_return (mk_integer (SCHEME_A_ result)); 4394 s_return (mk_integer (SCHEME_A_ result));
4007 } 4395 }
4008
4009 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4010 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4011
4012 case OP_TRUNCATE:
4013 {
4014 RVALUE n = rvalue (x);
4015 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4016 }
4017
4018 case OP_ROUND:
4019 if (is_integer (x))
4020 s_return (x);
4021
4022 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4023#endif 4396#endif
4024 4397
4025 case OP_ADD: /* + */ 4398 case OP_ADD: /* + */
4026 v = num_zero; 4399 v = num_zero;
4027 4400
… …
4115 else 4488 else
4116 Error_0 ("modulo: division by zero"); 4489 Error_0 ("modulo: division by zero");
4117 4490
4118 s_return (mk_number (SCHEME_A_ v)); 4491 s_return (mk_number (SCHEME_A_ v));
4119 4492
4120 case OP_CAR: /* car */ 4493 /* the compiler will optimize this mess... */
4121 s_return (caar (args)); 4494 case OP_CAR: op_car: s_return (car (x));
4122 4495 case OP_CDR: op_cdr: s_return (cdr (x));
4123 case OP_CDR: /* cdr */ 4496 case OP_CAAR: op_caar: x = car (x); goto op_car;
4124 s_return (cdar (args)); 4497 case OP_CADR: op_cadr: x = cdr (x); goto op_car;
4498 case OP_CDAR: op_cdar: x = car (x); goto op_cdr;
4499 case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr;
4500 case OP_CAAAR: op_caaar: x = car (x); goto op_caar;
4501 case OP_CAADR: op_caadr: x = cdr (x); goto op_caar;
4502 case OP_CADAR: op_cadar: x = car (x); goto op_cadr;
4503 case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr;
4504 case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar;
4505 case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar;
4506 case OP_CDDAR: op_cddar: x = car (x); goto op_cddr;
4507 case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr;
4508 case OP_CAAAAR: x = car (x); goto op_caaar;
4509 case OP_CAAADR: x = cdr (x); goto op_caaar;
4510 case OP_CAADAR: x = car (x); goto op_caadr;
4511 case OP_CAADDR: x = cdr (x); goto op_caadr;
4512 case OP_CADAAR: x = car (x); goto op_cadar;
4513 case OP_CADADR: x = cdr (x); goto op_cadar;
4514 case OP_CADDAR: x = car (x); goto op_caddr;
4515 case OP_CADDDR: x = cdr (x); goto op_caddr;
4516 case OP_CDAAAR: x = car (x); goto op_cdaar;
4517 case OP_CDAADR: x = cdr (x); goto op_cdaar;
4518 case OP_CDADAR: x = car (x); goto op_cdadr;
4519 case OP_CDADDR: x = cdr (x); goto op_cdadr;
4520 case OP_CDDAAR: x = car (x); goto op_cddar;
4521 case OP_CDDADR: x = cdr (x); goto op_cddar;
4522 case OP_CDDDAR: x = car (x); goto op_cdddr;
4523 case OP_CDDDDR: x = cdr (x); goto op_cdddr;
4125 4524
4126 case OP_CONS: /* cons */ 4525 case OP_CONS: /* cons */
4127 set_cdr (args, cadr (args)); 4526 set_cdr (args, cadr (args));
4128 s_return (args); 4527 s_return (args);
4129 4528
… …
4303 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4702 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4304 4703
4305 s_return (newstr); 4704 s_return (newstr);
4306 } 4705 }
4307 4706
4308 case OP_SUBSTR: /* substring */ 4707 case OP_STRING_COPY: /* substring/string-copy */
4309 { 4708 {
4310 char *str = strvalue (x); 4709 char *str = strvalue (x);
4311 int index0 = ivalue_unchecked (cadr (args)); 4710 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4312 int index1; 4711 int index1;
4313 int len; 4712 int len;
4314 4713
4315 if (index0 > strlength (x)) 4714 if (index0 > strlength (x))
4316 Error_1 ("substring: start out of bounds:", cadr (args)); 4715 Error_1 ("string->copy: start out of bounds:", cadr (args));
4317 4716
4318 if (cddr (args) != NIL) 4717 if (cddr (args) != NIL)
4319 { 4718 {
4320 index1 = ivalue_unchecked (caddr (args)); 4719 index1 = ivalue_unchecked (caddr (args));
4321 4720
4322 if (index1 > strlength (x) || index1 < index0) 4721 if (index1 > strlength (x) || index1 < index0)
4323 Error_1 ("substring: end out of bounds:", caddr (args)); 4722 Error_1 ("string->copy: end out of bounds:", caddr (args));
4324 } 4723 }
4325 else 4724 else
4326 index1 = strlength (x); 4725 index1 = strlength (x);
4327 4726
4328 len = index1 - index0; 4727 len = index1 - index0;
4329 x = mk_empty_string (SCHEME_A_ len, ' '); 4728 x = mk_counted_string (SCHEME_A_ str + index0, len);
4330 memcpy (strvalue (x), str + index0, len);
4331 strvalue (x)[len] = 0;
4332 4729
4333 s_return (x); 4730 s_return (x);
4334 } 4731 }
4335 4732
4336 case OP_VECTOR: /* vector */ 4733 case OP_VECTOR: /* vector */
… …
4378 } 4775 }
4379 4776
4380 case OP_VECLEN: /* vector-length */ 4777 case OP_VECLEN: /* vector-length */
4381 s_return (mk_integer (SCHEME_A_ veclength (x))); 4778 s_return (mk_integer (SCHEME_A_ veclength (x)));
4382 4779
4780 case OP_VECRESIZE:
4781 vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
4782 s_return (x);
4783
4383 case OP_VECREF: /* vector-ref */ 4784 case OP_VECREF: /* vector-ref */
4384 { 4785 {
4385 int index = ivalue_unchecked (cadr (args)); 4786 int index = ivalue_unchecked (cadr (args));
4386 4787
4387 if (index >= veclength (car (args)) && USE_ERROR_CHECKING) 4788 if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
… …
4406 } 4807 }
4407 4808
4408 if (USE_ERROR_CHECKING) abort (); 4809 if (USE_ERROR_CHECKING) abort ();
4409} 4810}
4410 4811
4411static int 4812/* relational ops */
4813ecb_hot static int
4412opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4814opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4413{ 4815{
4414 pointer x = SCHEME_V->args; 4816 pointer x = SCHEME_V->args;
4415 4817
4416 for (;;) 4818 for (;;)
… …
4437 } 4839 }
4438 4840
4439 s_return (S_T); 4841 s_return (S_T);
4440} 4842}
4441 4843
4442static int 4844/* predicates */
4845ecb_hot static int
4443opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4846opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4444{ 4847{
4445 pointer args = SCHEME_V->args; 4848 pointer args = SCHEME_V->args;
4446 pointer a = car (args); 4849 pointer a = car (args);
4447 pointer d = cdr (args); 4850 pointer d = cdr (args);
4448 int r; 4851 int r;
4449 4852
4450 switch (op) 4853 switch (op)
4451 { 4854 {
4452 case OP_NOT: /* not */ r = is_false (a) ; break; 4855 case OP_NOT: /* not */ r = is_false (a) ; break;
4453 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T; break; 4856 case OP_BOOLP: /* boolean? */ r = a == S_F || a == S_T ; break;
4454 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break; 4857 case OP_EOFOBJP: /* eof-object? */ r = a == S_EOF ; break;
4455 case OP_NULLP: /* null? */ r = a == NIL ; break; 4858 case OP_NULLP: /* null? */ r = a == NIL ; break;
4456 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break; 4859 case OP_SYMBOLP: /* symbol? */ r = is_symbol (a) ; break;
4860 case OP_GENSYMP: /* gensym? */ r = is_gensym (SCHEME_A_ a); break;
4457 case OP_NUMBERP: /* number? */ r = is_number (a) ; break; 4861 case OP_NUMBERP: /* number? */ r = is_number (a) ; break;
4458 case OP_STRINGP: /* string? */ r = is_string (a) ; break; 4862 case OP_STRINGP: /* string? */ r = is_string (a) ; break;
4459 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break; 4863 case OP_INTEGERP: /* integer? */ r = is_integer (a) ; break;
4460 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */ 4864 case OP_REALP: /* real? */ r = is_number (a) ; break; /* all numbers are real */
4461 case OP_CHARP: /* char? */ r = is_character (a) ; break; 4865 case OP_CHARP: /* char? */ r = is_character (a) ; break;
4462 4866
4463#if USE_CHAR_CLASSIFIERS 4867#if USE_CHAR_CLASSIFIERS
4464 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break; 4868 case OP_CHARAP: /* char-alphabetic? */ r = Cisalpha (ivalue_unchecked (a)); break;
4465 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break; 4869 case OP_CHARNP: /* char-numeric? */ r = Cisdigit (ivalue_unchecked (a)); break;
4466 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break; 4870 case OP_CHARWP: /* char-whitespace? */ r = Cisspace (ivalue_unchecked (a)); break;
… …
4493 } 4897 }
4494 4898
4495 s_retbool (r); 4899 s_retbool (r);
4496} 4900}
4497 4901
4498static int 4902/* promises, list ops, ports */
4903ecb_hot static int
4499opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4904opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4500{ 4905{
4501 pointer args = SCHEME_V->args; 4906 pointer args = SCHEME_V->args;
4502 pointer a = car (args); 4907 pointer a = car (args);
4503 pointer x, y; 4908 pointer x, y;
… …
4516 } 4921 }
4517 else 4922 else
4518 s_return (SCHEME_V->code); 4923 s_return (SCHEME_V->code);
4519 4924
4520 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4925 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4521 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4926 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4522 s_return (SCHEME_V->value); 4927 s_return (SCHEME_V->value);
4523 4928
4524#if USE_PORTS 4929#if USE_PORTS
4930
4931 case OP_EOF_OBJECT: /* eof-object */
4932 s_return (S_EOF);
4525 4933
4526 case OP_WRITE: /* write */ 4934 case OP_WRITE: /* write */
4527 case OP_DISPLAY: /* display */ 4935 case OP_DISPLAY: /* display */
4528 case OP_WRITE_CHAR: /* write-char */ 4936 case OP_WRITE_CHAR: /* write-char */
4529 if (is_pair (cdr (SCHEME_V->args))) 4937 if (is_pair (cdr (SCHEME_V->args)))
… …
4543 else 4951 else
4544 SCHEME_V->print_flag = 0; 4952 SCHEME_V->print_flag = 0;
4545 4953
4546 s_goto (OP_P0LIST); 4954 s_goto (OP_P0LIST);
4547 4955
4956 //TODO: move to scheme
4548 case OP_NEWLINE: /* newline */ 4957 case OP_NEWLINE: /* newline */
4549 if (is_pair (args)) 4958 if (is_pair (args))
4550 { 4959 {
4551 if (a != SCHEME_V->outport) 4960 if (a != SCHEME_V->outport)
4552 { 4961 {
… …
4554 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4963 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4555 SCHEME_V->outport = a; 4964 SCHEME_V->outport = a;
4556 } 4965 }
4557 } 4966 }
4558 4967
4559 putstr (SCHEME_A_ "\n"); 4968 putcharacter (SCHEME_A_ '\n');
4560 s_return (S_T); 4969 s_return (S_T);
4561#endif 4970#endif
4562 4971
4563 case OP_ERR0: /* error */ 4972 case OP_ERR0: /* error */
4564 SCHEME_V->retcode = -1; 4973 SCHEME_V->retcode = -1;
… …
4573 putstr (SCHEME_A_ strvalue (car (args))); 4982 putstr (SCHEME_A_ strvalue (car (args)));
4574 SCHEME_V->args = cdr (args); 4983 SCHEME_V->args = cdr (args);
4575 s_goto (OP_ERR1); 4984 s_goto (OP_ERR1);
4576 4985
4577 case OP_ERR1: /* error */ 4986 case OP_ERR1: /* error */
4578 putstr (SCHEME_A_ " "); 4987 putcharacter (SCHEME_A_ ' ');
4579 4988
4580 if (args != NIL) 4989 if (args != NIL)
4581 { 4990 {
4582 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); 4991 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4583 SCHEME_V->args = a; 4992 SCHEME_V->args = a;
4584 SCHEME_V->print_flag = 1; 4993 SCHEME_V->print_flag = 1;
4585 s_goto (OP_P0LIST); 4994 s_goto (OP_P0LIST);
4586 } 4995 }
4587 else 4996 else
4588 { 4997 {
4589 putstr (SCHEME_A_ "\n"); 4998 putcharacter (SCHEME_A_ '\n');
4590 4999
4591 if (SCHEME_V->interactive_repl) 5000 if (SCHEME_V->interactive_repl)
4592 s_goto (OP_T0LVL); 5001 s_goto (OP_T0LVL);
4593 else 5002 else
4594 return -1; 5003 return -1;
… …
4671 SCHEME_V->gc_verbose = (a != S_F); 5080 SCHEME_V->gc_verbose = (a != S_F);
4672 s_retbool (was); 5081 s_retbool (was);
4673 } 5082 }
4674 5083
4675 case OP_NEWSEGMENT: /* new-segment */ 5084 case OP_NEWSEGMENT: /* new-segment */
5085#if 0
4676 if (!is_pair (args) || !is_number (a)) 5086 if (!is_pair (args) || !is_number (a))
4677 Error_0 ("new-segment: argument must be a number"); 5087 Error_0 ("new-segment: argument must be a number");
4678 5088#endif
4679 alloc_cellseg (SCHEME_A_ ivalue (a)); 5089 s_retbool (alloc_cellseg (SCHEME_A));
4680
4681 s_return (S_T);
4682 5090
4683 case OP_OBLIST: /* oblist */ 5091 case OP_OBLIST: /* oblist */
4684 s_return (oblist_all_symbols (SCHEME_A)); 5092 s_return (oblist_all_symbols (SCHEME_A));
4685 5093
4686#if USE_PORTS 5094#if USE_PORTS
… …
4756 s_return (p == NIL ? S_F : p); 5164 s_return (p == NIL ? S_F : p);
4757 } 5165 }
4758 5166
4759 case OP_GET_OUTSTRING: /* get-output-string */ 5167 case OP_GET_OUTSTRING: /* get-output-string */
4760 { 5168 {
4761 port *p; 5169 port *p = port (a);
4762 5170
4763 if ((p = a->object.port)->kind & port_string) 5171 if (p->kind & port_string)
4764 { 5172 {
4765 off_t size; 5173 off_t size;
4766 char *str; 5174 char *str;
4767 5175
4768 size = p->rep.string.curr - p->rep.string.start + 1; 5176 size = p->rep.string.curr - p->rep.string.start + 1;
… …
4803 } 5211 }
4804 5212
4805 if (USE_ERROR_CHECKING) abort (); 5213 if (USE_ERROR_CHECKING) abort ();
4806} 5214}
4807 5215
4808static int 5216/* reading */
5217ecb_cold static int
4809opexe_5 (SCHEME_P_ enum scheme_opcodes op) 5218opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4810{ 5219{
4811 pointer args = SCHEME_V->args; 5220 pointer args = SCHEME_V->args;
4812 pointer x; 5221 pointer x;
4813 5222
… …
4873 int res; 5282 int res;
4874 5283
4875 if (is_pair (args)) 5284 if (is_pair (args))
4876 p = car (args); 5285 p = car (args);
4877 5286
4878 res = p->object.port->kind & port_string; 5287 res = port (p)->kind & port_string;
4879 5288
4880 s_retbool (res); 5289 s_retbool (res);
4881 } 5290 }
4882 5291
4883 case OP_SET_INPORT: /* set-input-port */ 5292 case OP_SET_INPORT: /* set-input-port */
… …
4892 case OP_RDSEXPR: 5301 case OP_RDSEXPR:
4893 switch (SCHEME_V->tok) 5302 switch (SCHEME_V->tok)
4894 { 5303 {
4895 case TOK_EOF: 5304 case TOK_EOF:
4896 s_return (S_EOF); 5305 s_return (S_EOF);
4897 /* NOTREACHED */
4898 5306
4899 case TOK_VEC: 5307 case TOK_VEC:
4900 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL); 5308 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
4901 /* fall through */ 5309 /* fall through */
4902 5310
… …
4905 5313
4906 if (SCHEME_V->tok == TOK_RPAREN) 5314 if (SCHEME_V->tok == TOK_RPAREN)
4907 s_return (NIL); 5315 s_return (NIL);
4908 else if (SCHEME_V->tok == TOK_DOT) 5316 else if (SCHEME_V->tok == TOK_DOT)
4909 Error_0 ("syntax error: illegal dot expression"); 5317 Error_0 ("syntax error: illegal dot expression");
4910 else 5318
4911 {
4912 SCHEME_V->nesting_stack[SCHEME_V->file_i]++; 5319 SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
4913 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL); 5320 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
4914 s_goto (OP_RDSEXPR); 5321 s_goto (OP_RDSEXPR);
4915 }
4916 5322
4917 case TOK_QUOTE: 5323 case TOK_QUOTE:
4918 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL); 5324 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
4919 SCHEME_V->tok = token (SCHEME_A); 5325 SCHEME_V->tok = token (SCHEME_A);
4920 s_goto (OP_RDSEXPR); 5326 s_goto (OP_RDSEXPR);
… …
4926 { 5332 {
4927 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL); 5333 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
4928 SCHEME_V->tok = TOK_LPAREN; 5334 SCHEME_V->tok = TOK_LPAREN;
4929 s_goto (OP_RDSEXPR); 5335 s_goto (OP_RDSEXPR);
4930 } 5336 }
4931 else 5337
4932 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); 5338 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
4933
4934 s_goto (OP_RDSEXPR); 5339 s_goto (OP_RDSEXPR);
4935 5340
4936 case TOK_COMMA: 5341 case TOK_COMMA:
4937 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL); 5342 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
4938 SCHEME_V->tok = token (SCHEME_A); 5343 SCHEME_V->tok = token (SCHEME_A);
… …
4948 5353
4949 case TOK_DOTATOM: 5354 case TOK_DOTATOM:
4950 SCHEME_V->strbuff[0] = '.'; 5355 SCHEME_V->strbuff[0] = '.';
4951 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); 5356 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
4952 5357
5358 case TOK_STRATOM:
5359 //TODO: haven't checked whether the garbage collector could interfere and free x
5360 gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded
5361 x = readstrexp (SCHEME_A_ '|');
5362 s_return (mk_atom (SCHEME_A_ strvalue (x)));
5363
4953 case TOK_DQUOTE: 5364 case TOK_DQUOTE:
4954 x = readstrexp (SCHEME_A_ '"'); 5365 x = readstrexp (SCHEME_A_ '"');
4955 5366
4956 if (x == S_F) 5367 if (x == S_F)
4957 Error_0 ("Error reading string"); 5368 Error_0 ("Error reading string");
… …
4963 { 5374 {
4964 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1); 5375 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);
4965 5376
4966 if (f == NIL) 5377 if (f == NIL)
4967 Error_0 ("undefined sharp expression"); 5378 Error_0 ("undefined sharp expression");
4968 else 5379
4969 {
4970 SCHEME_V->code = cons (slot_value_in_env (f), NIL); 5380 SCHEME_V->code = cons (slot_value_in_env (f), NIL);
4971 s_goto (OP_EVAL); 5381 s_goto (OP_EVAL);
4972 }
4973 } 5382 }
4974 5383
4975 case TOK_SHARP_CONST: 5384 case TOK_SHARP_CONST:
4976 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL) 5385 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
4977 Error_0 ("undefined sharp expression"); 5386 Error_0 ("undefined sharp expression");
4978 else 5387
4979 s_return (x); 5388 s_return (x);
4980 5389
4981 default: 5390 default:
4982 Error_0 ("syntax error: illegal token"); 5391 Error_0 ("syntax error: illegal token");
4983 } 5392 }
4984 5393
… …
5077 pointer b = cdr (args); 5486 pointer b = cdr (args);
5078 int ok_abbr = ok_abbrev (b); 5487 int ok_abbr = ok_abbrev (b);
5079 SCHEME_V->args = car (b); 5488 SCHEME_V->args = car (b);
5080 5489
5081 if (a == SCHEME_V->QUOTE && ok_abbr) 5490 if (a == SCHEME_V->QUOTE && ok_abbr)
5082 putstr (SCHEME_A_ "'"); 5491 putcharacter (SCHEME_A_ '\'');
5083 else if (a == SCHEME_V->QQUOTE && ok_abbr) 5492 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5084 putstr (SCHEME_A_ "`"); 5493 putcharacter (SCHEME_A_ '`');
5085 else if (a == SCHEME_V->UNQUOTE && ok_abbr) 5494 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5086 putstr (SCHEME_A_ ","); 5495 putcharacter (SCHEME_A_ ',');
5087 else if (a == SCHEME_V->UNQUOTESP && ok_abbr) 5496 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5088 putstr (SCHEME_A_ ",@"); 5497 putstr (SCHEME_A_ ",@");
5089 else 5498 else
5090 { 5499 {
5091 putstr (SCHEME_A_ "("); 5500 putcharacter (SCHEME_A_ '(');
5092 s_save (SCHEME_A_ OP_P1LIST, b, NIL); 5501 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5093 SCHEME_V->args = a; 5502 SCHEME_V->args = a;
5094 } 5503 }
5095 5504
5096 s_goto (OP_P0LIST); 5505 s_goto (OP_P0LIST);
… …
5098 5507
5099 case OP_P1LIST: 5508 case OP_P1LIST:
5100 if (is_pair (args)) 5509 if (is_pair (args))
5101 { 5510 {
5102 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); 5511 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5103 putstr (SCHEME_A_ " "); 5512 putcharacter (SCHEME_A_ ' ');
5104 SCHEME_V->args = car (args); 5513 SCHEME_V->args = car (args);
5105 s_goto (OP_P0LIST); 5514 s_goto (OP_P0LIST);
5106 } 5515 }
5107 else if (is_vector (args)) 5516 else if (is_vector (args))
5108 { 5517 {
… …
5116 { 5525 {
5117 putstr (SCHEME_A_ " . "); 5526 putstr (SCHEME_A_ " . ");
5118 printatom (SCHEME_A_ args, SCHEME_V->print_flag); 5527 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5119 } 5528 }
5120 5529
5121 putstr (SCHEME_A_ ")"); 5530 putcharacter (SCHEME_A_ ')');
5122 s_return (S_T); 5531 s_return (S_T);
5123 } 5532 }
5124 5533
5125 case OP_PVECFROM: 5534 case OP_PVECFROM:
5126 { 5535 {
… …
5128 pointer vec = car (args); 5537 pointer vec = car (args);
5129 int len = veclength (vec); 5538 int len = veclength (vec);
5130 5539
5131 if (i == len) 5540 if (i == len)
5132 { 5541 {
5133 putstr (SCHEME_A_ ")"); 5542 putcharacter (SCHEME_A_ ')');
5134 s_return (S_T); 5543 s_return (S_T);
5135 } 5544 }
5136 else 5545 else
5137 { 5546 {
5138 pointer elem = vector_get (vec, i); 5547 pointer elem = vector_get (vec, i);
… …
5140 ivalue_unchecked (cdr (args)) = i + 1; 5549 ivalue_unchecked (cdr (args)) = i + 1;
5141 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5550 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5142 SCHEME_V->args = elem; 5551 SCHEME_V->args = elem;
5143 5552
5144 if (i > 0) 5553 if (i > 0)
5145 putstr (SCHEME_A_ " "); 5554 putcharacter (SCHEME_A_ ' ');
5146 5555
5147 s_goto (OP_P0LIST); 5556 s_goto (OP_P0LIST);
5148 } 5557 }
5149 } 5558 }
5150 } 5559 }
5151 5560
5152 if (USE_ERROR_CHECKING) abort (); 5561 if (USE_ERROR_CHECKING) abort ();
5153} 5562}
5154 5563
5155static int 5564/* list ops */
5565ecb_hot static int
5156opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5566opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5157{ 5567{
5158 pointer args = SCHEME_V->args; 5568 pointer args = SCHEME_V->args;
5159 pointer a = car (args); 5569 pointer a = car (args);
5160 pointer x, y; 5570 pointer x, y;
… …
5183 break; 5593 break;
5184 } 5594 }
5185 5595
5186 if (is_pair (y)) 5596 if (is_pair (y))
5187 s_return (car (y)); 5597 s_return (car (y));
5188 else 5598
5189 s_return (S_F); 5599 s_return (S_F);
5190
5191 5600
5192 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5601 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5193 SCHEME_V->args = a; 5602 SCHEME_V->args = a;
5194 5603
5195 if (SCHEME_V->args == NIL) 5604 if (SCHEME_V->args == NIL)
5196 s_return (S_F); 5605 s_return (S_F);
5197 else if (is_closure (SCHEME_V->args)) 5606 else if (is_closure (SCHEME_V->args) || is_macro (SCHEME_V->args))
5198 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5607 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5199 else if (is_macro (SCHEME_V->args)) 5608
5200 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5201 else
5202 s_return (S_F); 5609 s_return (S_F);
5203 5610
5204 case OP_CLOSUREP: /* closure? */ 5611 case OP_CLOSUREP: /* closure? */
5205 /* 5612 /*
5206 * Note, macro object is also a closure. 5613 * Note, macro object is also a closure.
5207 * Therefore, (closure? <#MACRO>) ==> #t 5614 * Therefore, (closure? <#MACRO>) ==> #t
5615 * (schmorp) well, obviously not, fix? TODO
5208 */ 5616 */
5209 s_retbool (is_closure (a)); 5617 s_retbool (is_closure (a));
5210 5618
5211 case OP_MACROP: /* macro? */ 5619 case OP_MACROP: /* macro? */
5212 s_retbool (is_macro (a)); 5620 s_retbool (is_macro (a));
… …
5217 5625
5218/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5626/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5219typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); 5627typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5220 5628
5221typedef int (*test_predicate)(pointer); 5629typedef int (*test_predicate)(pointer);
5222static int 5630
5631ecb_hot static int
5223tst_any (pointer p) 5632tst_any (pointer p)
5224{ 5633{
5225 return 1; 5634 return 1;
5226} 5635}
5227 5636
5228static int 5637ecb_hot static int
5229tst_inonneg (pointer p) 5638tst_inonneg (pointer p)
5230{ 5639{
5231 return is_integer (p) && ivalue_unchecked (p) >= 0; 5640 return is_integer (p) && ivalue_unchecked (p) >= 0;
5232} 5641}
5233 5642
5234static int 5643ecb_hot static int
5235tst_is_list (SCHEME_P_ pointer p) 5644tst_is_list (SCHEME_P_ pointer p)
5236{ 5645{
5237 return p == NIL || is_pair (p); 5646 return p == NIL || is_pair (p);
5238} 5647}
5239 5648
… …
5282#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" 5691#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5283#include "opdefines.h" 5692#include "opdefines.h"
5284#undef OP_DEF 5693#undef OP_DEF
5285; 5694;
5286 5695
5287static const char * 5696ecb_cold static const char *
5288opname (int idx) 5697opname (int idx)
5289{ 5698{
5290 const char *name = opnames; 5699 const char *name = opnames;
5291 5700
5292 /* should do this at compile time, but would require external program, right? */ 5701 /* should do this at compile time, but would require external program, right? */
… …
5294 name += strlen (name) + 1; 5703 name += strlen (name) + 1;
5295 5704
5296 return *name ? name : "ILLEGAL"; 5705 return *name ? name : "ILLEGAL";
5297} 5706}
5298 5707
5299static const char * 5708ecb_cold static const char *
5300procname (pointer x) 5709procname (pointer x)
5301{ 5710{
5302 return opname (procnum (x)); 5711 return opname (procnum (x));
5303} 5712}
5304 5713
… …
5324#undef OP_DEF 5733#undef OP_DEF
5325 {0} 5734 {0}
5326}; 5735};
5327 5736
5328/* kernel of this interpreter */ 5737/* kernel of this interpreter */
5329static void ecb_hot 5738ecb_hot static void
5330Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5739Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5331{ 5740{
5332 SCHEME_V->op = op; 5741 SCHEME_V->op = op;
5333 5742
5334 for (;;) 5743 for (;;)
… …
5417 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) 5826 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5418 return; 5827 return;
5419 5828
5420 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5829 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5421 { 5830 {
5422 xwrstr ("No memory!\n"); 5831 putstr (SCHEME_A_ "No memory!\n");
5423 return; 5832 return;
5424 } 5833 }
5425 } 5834 }
5426} 5835}
5427 5836
5428/* ========== Initialization of internal keywords ========== */ 5837/* ========== Initialization of internal keywords ========== */
5429 5838
5430static void 5839ecb_cold static void
5431assign_syntax (SCHEME_P_ const char *name) 5840assign_syntax (SCHEME_P_ const char *name)
5432{ 5841{
5433 pointer x = oblist_add_by_name (SCHEME_A_ name); 5842 pointer x = oblist_add_by_name (SCHEME_A_ name);
5434 set_typeflag (x, typeflag (x) | T_SYNTAX); 5843 set_typeflag (x, typeflag (x) | T_SYNTAX);
5435} 5844}
5436 5845
5437static void 5846ecb_cold static void
5438assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5847assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5439{ 5848{
5440 pointer x = mk_symbol (SCHEME_A_ name); 5849 pointer x = mk_symbol (SCHEME_A_ name);
5441 pointer y = mk_proc (SCHEME_A_ op); 5850 pointer y = mk_proc (SCHEME_A_ op);
5442 new_slot_in_env (SCHEME_A_ x, y); 5851 new_slot_in_env (SCHEME_A_ x, y);
… …
5450 ivalue_unchecked (y) = op; 5859 ivalue_unchecked (y) = op;
5451 return y; 5860 return y;
5452} 5861}
5453 5862
5454/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5863/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5455static int 5864ecb_hot static int
5456syntaxnum (pointer p) 5865syntaxnum (pointer p)
5457{ 5866{
5458 const char *s = strvalue (car (p)); 5867 const char *s = strvalue (p);
5459 5868
5460 switch (strlength (car (p))) 5869 switch (strlength (p))
5461 { 5870 {
5462 case 2: 5871 case 2:
5463 if (s[0] == 'i') 5872 if (s[0] == 'i')
5464 return OP_IF0; /* if */ 5873 return OP_IF0; /* if */
5465 else 5874 else
… …
5540ecb_cold int 5949ecb_cold int
5541scheme_init (SCHEME_P) 5950scheme_init (SCHEME_P)
5542{ 5951{
5543 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5952 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5544 pointer x; 5953 pointer x;
5954
5955 /* this memset is not strictly correct, as we assume (intcache)
5956 * that memset 0 will also set pointers to 0, but memset does
5957 * of course not guarantee that. screw such systems.
5958 */
5959 memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5545 5960
5546 num_set_fixnum (num_zero, 1); 5961 num_set_fixnum (num_zero, 1);
5547 num_set_ivalue (num_zero, 0); 5962 num_set_ivalue (num_zero, 0);
5548 num_set_fixnum (num_one, 1); 5963 num_set_fixnum (num_one, 1);
5549 num_set_ivalue (num_one, 1); 5964 num_set_ivalue (num_one, 1);
… …
5561 SCHEME_V->save_inport = NIL; 5976 SCHEME_V->save_inport = NIL;
5562 SCHEME_V->loadport = NIL; 5977 SCHEME_V->loadport = NIL;
5563 SCHEME_V->nesting = 0; 5978 SCHEME_V->nesting = 0;
5564 SCHEME_V->interactive_repl = 0; 5979 SCHEME_V->interactive_repl = 0;
5565 5980
5566 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 5981 if (!alloc_cellseg (SCHEME_A))
5567 { 5982 {
5568#if USE_ERROR_CHECKING 5983#if USE_ERROR_CHECKING
5569 SCHEME_V->no_memory = 1; 5984 SCHEME_V->no_memory = 1;
5570 return 0; 5985 return 0;
5571#endif 5986#endif
5572 } 5987 }
5573 5988
5574 SCHEME_V->gc_verbose = 0; 5989 SCHEME_V->gc_verbose = 0;
5575 dump_stack_initialize (SCHEME_A); 5990 dump_stack_initialize (SCHEME_A);
5576 SCHEME_V->code = NIL; 5991 SCHEME_V->code = NIL;
5577 SCHEME_V->args = NIL; 5992 SCHEME_V->args = NIL;
5578 SCHEME_V->envir = NIL; 5993 SCHEME_V->envir = NIL;
5994 SCHEME_V->value = NIL;
5579 SCHEME_V->tracing = 0; 5995 SCHEME_V->tracing = 0;
5580 5996
5581 /* init NIL */ 5997 /* init NIL */
5582 set_typeflag (NIL, T_ATOM | T_MARK); 5998 set_typeflag (NIL, T_ATOM | T_MARK);
5583 set_car (NIL, NIL); 5999 set_car (NIL, NIL);
… …
5639 6055
5640 return !SCHEME_V->no_memory; 6056 return !SCHEME_V->no_memory;
5641} 6057}
5642 6058
5643#if USE_PORTS 6059#if USE_PORTS
5644void 6060ecb_cold void
5645scheme_set_input_port_file (SCHEME_P_ int fin) 6061scheme_set_input_port_file (SCHEME_P_ int fin)
5646{ 6062{
5647 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 6063 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5648} 6064}
5649 6065
5650void 6066ecb_cold void
5651scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 6067scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5652{ 6068{
5653 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 6069 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5654} 6070}
5655 6071
5656void 6072ecb_cold void
5657scheme_set_output_port_file (SCHEME_P_ int fout) 6073scheme_set_output_port_file (SCHEME_P_ int fout)
5658{ 6074{
5659 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 6075 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5660} 6076}
5661 6077
5662void 6078ecb_cold void
5663scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 6079scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5664{ 6080{
5665 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 6081 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5666} 6082}
5667#endif 6083#endif
5668 6084
5669void 6085ecb_cold void
5670scheme_set_external_data (SCHEME_P_ void *p) 6086scheme_set_external_data (SCHEME_P_ void *p)
5671{ 6087{
5672 SCHEME_V->ext_data = p; 6088 SCHEME_V->ext_data = p;
5673} 6089}
5674 6090
… …
5706 SCHEME_V->loadport = NIL; 6122 SCHEME_V->loadport = NIL;
5707 SCHEME_V->gc_verbose = 0; 6123 SCHEME_V->gc_verbose = 0;
5708 gc (SCHEME_A_ NIL, NIL); 6124 gc (SCHEME_A_ NIL, NIL);
5709 6125
5710 for (i = 0; i <= SCHEME_V->last_cell_seg; i++) 6126 for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5711 free (SCHEME_V->alloc_seg[i]); 6127 free (SCHEME_V->cell_seg[i]);
5712 6128
5713#if SHOW_ERROR_LINE 6129#if SHOW_ERROR_LINE
5714 for (i = 0; i <= SCHEME_V->file_i; i++) 6130 for (i = 0; i <= SCHEME_V->file_i; i++)
5715 {
5716 if (SCHEME_V->load_stack[i].kind & port_file) 6131 if (SCHEME_V->load_stack[i].kind & port_file)
5717 { 6132 {
5718 fname = SCHEME_V->load_stack[i].rep.stdio.filename; 6133 fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5719 6134
5720 if (fname) 6135 if (fname)
5721 free (fname); 6136 free (fname);
5722 } 6137 }
5723 }
5724#endif 6138#endif
5725} 6139}
5726 6140
5727void 6141ecb_cold void
5728scheme_load_file (SCHEME_P_ int fin) 6142scheme_load_file (SCHEME_P_ int fin)
5729{ 6143{
5730 scheme_load_named_file (SCHEME_A_ fin, 0); 6144 scheme_load_named_file (SCHEME_A_ fin, 0);
5731} 6145}
5732 6146
5733void 6147ecb_cold void
5734scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 6148scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5735{ 6149{
5736 dump_stack_reset (SCHEME_A); 6150 dump_stack_reset (SCHEME_A);
5737 SCHEME_V->envir = SCHEME_V->global_env; 6151 SCHEME_V->envir = SCHEME_V->global_env;
5738 SCHEME_V->file_i = 0; 6152 SCHEME_V->file_i = 0;
5739 SCHEME_V->load_stack[0].unget = -1; 6153 SCHEME_V->load_stack[0].unget = -1;
5740 SCHEME_V->load_stack[0].kind = port_input | port_file; 6154 SCHEME_V->load_stack[0].kind = port_input | port_file;
5741 SCHEME_V->load_stack[0].rep.stdio.file = fin; 6155 SCHEME_V->load_stack[0].rep.stdio.file = fin;
5742#if USE_PORTS
5743 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 6156 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5744#endif
5745 SCHEME_V->retcode = 0; 6157 SCHEME_V->retcode = 0;
5746 6158
5747#if USE_PORTS
5748 if (fin == STDIN_FILENO) 6159 if (fin == STDIN_FILENO)
5749 SCHEME_V->interactive_repl = 1; 6160 SCHEME_V->interactive_repl = 1;
5750#endif
5751 6161
5752#if USE_PORTS 6162#if USE_PORTS
5753#if SHOW_ERROR_LINE 6163#if SHOW_ERROR_LINE
5754 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0; 6164 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5755 6165
… …
5759#endif 6169#endif
5760 6170
5761 SCHEME_V->inport = SCHEME_V->loadport; 6171 SCHEME_V->inport = SCHEME_V->loadport;
5762 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6172 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5763 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6173 Eval_Cycle (SCHEME_A_ OP_T0LVL);
6174
5764 set_typeflag (SCHEME_V->loadport, T_ATOM); 6175 set_typeflag (SCHEME_V->loadport, T_ATOM);
5765 6176
5766 if (SCHEME_V->retcode == 0) 6177 if (SCHEME_V->retcode == 0)
5767 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6178 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5768} 6179}
5769 6180
5770void 6181ecb_cold void
5771scheme_load_string (SCHEME_P_ const char *cmd) 6182scheme_load_string (SCHEME_P_ const char *cmd)
5772{ 6183{
6184#if USE_PORTs
5773 dump_stack_reset (SCHEME_A); 6185 dump_stack_reset (SCHEME_A);
5774 SCHEME_V->envir = SCHEME_V->global_env; 6186 SCHEME_V->envir = SCHEME_V->global_env;
5775 SCHEME_V->file_i = 0; 6187 SCHEME_V->file_i = 0;
5776 SCHEME_V->load_stack[0].kind = port_input | port_string; 6188 SCHEME_V->load_stack[0].kind = port_input | port_string;
5777 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ 6189 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5778 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); 6190 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5779 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; 6191 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5780#if USE_PORTS
5781 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 6192 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5782#endif
5783 SCHEME_V->retcode = 0; 6193 SCHEME_V->retcode = 0;
5784 SCHEME_V->interactive_repl = 0; 6194 SCHEME_V->interactive_repl = 0;
5785 SCHEME_V->inport = SCHEME_V->loadport; 6195 SCHEME_V->inport = SCHEME_V->loadport;
5786 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6196 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5787 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6197 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5788 set_typeflag (SCHEME_V->loadport, T_ATOM); 6198 set_typeflag (SCHEME_V->loadport, T_ATOM);
5789 6199
5790 if (SCHEME_V->retcode == 0) 6200 if (SCHEME_V->retcode == 0)
5791 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6201 SCHEME_V->retcode = SCHEME_V->nesting != 0;
6202#else
6203 abort ();
6204#endif
5792} 6205}
5793 6206
5794void 6207ecb_cold void
5795scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 6208scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5796{ 6209{
5797 pointer x; 6210 pointer x;
5798 6211
5799 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 6212 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5804 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 6217 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5805} 6218}
5806 6219
5807#if !STANDALONE 6220#if !STANDALONE
5808 6221
5809void 6222ecb_cold void
5810scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 6223scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5811{ 6224{
5812 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 6225 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5813} 6226}
5814 6227
5815void 6228ecb_cold void
5816scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 6229scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5817{ 6230{
5818 int i; 6231 int i;
5819 6232
5820 for (i = 0; i < count; i++) 6233 for (i = 0; i < count; i++)
5821 scheme_register_foreign_func (SCHEME_A_ list + i); 6234 scheme_register_foreign_func (SCHEME_A_ list + i);
5822} 6235}
5823 6236
5824pointer 6237ecb_cold pointer
5825scheme_apply0 (SCHEME_P_ const char *procname) 6238scheme_apply0 (SCHEME_P_ const char *procname)
5826{ 6239{
5827 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 6240 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5828} 6241}
5829 6242
5830void 6243ecb_cold void
5831save_from_C_call (SCHEME_P) 6244save_from_C_call (SCHEME_P)
5832{ 6245{
5833 pointer saved_data = cons (car (S_SINK), 6246 pointer saved_data = cons (car (S_SINK),
5834 cons (SCHEME_V->envir, 6247 cons (SCHEME_V->envir,
5835 SCHEME_V->dump)); 6248 SCHEME_V->dump));
… …
5839 /* Truncate the dump stack so TS will return here when done, not 6252 /* Truncate the dump stack so TS will return here when done, not
5840 directly resume pre-C-call operations. */ 6253 directly resume pre-C-call operations. */
5841 dump_stack_reset (SCHEME_A); 6254 dump_stack_reset (SCHEME_A);
5842} 6255}
5843 6256
5844void 6257ecb_cold void
5845restore_from_C_call (SCHEME_P) 6258restore_from_C_call (SCHEME_P)
5846{ 6259{
5847 set_car (S_SINK, caar (SCHEME_V->c_nest)); 6260 set_car (S_SINK, caar (SCHEME_V->c_nest));
5848 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 6261 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5849 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 6262 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5850 /* Pop */ 6263 /* Pop */
5851 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 6264 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5852} 6265}
5853 6266
5854/* "func" and "args" are assumed to be already eval'ed. */ 6267/* "func" and "args" are assumed to be already eval'ed. */
5855pointer 6268ecb_cold pointer
5856scheme_call (SCHEME_P_ pointer func, pointer args) 6269scheme_call (SCHEME_P_ pointer func, pointer args)
5857{ 6270{
5858 int old_repl = SCHEME_V->interactive_repl; 6271 int old_repl = SCHEME_V->interactive_repl;
5859 6272
5860 SCHEME_V->interactive_repl = 0; 6273 SCHEME_V->interactive_repl = 0;
… …
5867 SCHEME_V->interactive_repl = old_repl; 6280 SCHEME_V->interactive_repl = old_repl;
5868 restore_from_C_call (SCHEME_A); 6281 restore_from_C_call (SCHEME_A);
5869 return SCHEME_V->value; 6282 return SCHEME_V->value;
5870} 6283}
5871 6284
5872pointer 6285ecb_cold pointer
5873scheme_eval (SCHEME_P_ pointer obj) 6286scheme_eval (SCHEME_P_ pointer obj)
5874{ 6287{
5875 int old_repl = SCHEME_V->interactive_repl; 6288 int old_repl = SCHEME_V->interactive_repl;
5876 6289
5877 SCHEME_V->interactive_repl = 0; 6290 SCHEME_V->interactive_repl = 0;
… …
5889 6302
5890/* ========== Main ========== */ 6303/* ========== Main ========== */
5891 6304
5892#if STANDALONE 6305#if STANDALONE
5893 6306
5894int 6307ecb_cold int
5895main (int argc, char **argv) 6308main (int argc, char **argv)
5896{ 6309{
5897# if USE_MULTIPLICITY 6310# if USE_MULTIPLICITY
5898 scheme ssc; 6311 scheme ssc;
5899 scheme *const SCHEME_V = &ssc; 6312 scheme *const SCHEME_V = &ssc;
… …
5901# endif 6314# endif
5902 int fin; 6315 int fin;
5903 char *file_name = InitFile; 6316 char *file_name = InitFile;
5904 int retcode; 6317 int retcode;
5905 int isfile = 1; 6318 int isfile = 1;
6319#if EXPERIMENT
6320 system ("ps v $PPID");
6321#endif
5906 6322
5907 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6323 if (argc == 2 && strcmp (argv[1], "-?") == 0)
5908 { 6324 {
5909 xwrstr ("Usage: tinyscheme -?\n"); 6325 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
5910 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6326 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
5911 xwrstr ("followed by\n"); 6327 putstr (SCHEME_A_ "followed by\n");
5912 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6328 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
5913 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6329 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
5914 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6330 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
5915 xwrstr ("Use - as filename for stdin.\n"); 6331 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
5916 return 1; 6332 return 1;
5917 } 6333 }
5918 6334
5919 if (!scheme_init (SCHEME_A)) 6335 if (!scheme_init (SCHEME_A))
5920 { 6336 {
5921 xwrstr ("Could not initialize!\n"); 6337 putstr (SCHEME_A_ "Could not initialize!\n");
5922 return 2; 6338 return 2;
5923 } 6339 }
5924 6340
5925# if USE_PORTS 6341# if USE_PORTS
5926 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6342 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
5939 } 6355 }
5940#endif 6356#endif
5941 6357
5942 do 6358 do
5943 { 6359 {
5944#if USE_PORTS
5945 if (strcmp (file_name, "-") == 0) 6360 if (strcmp (file_name, "-") == 0)
5946 fin = STDIN_FILENO; 6361 fin = STDIN_FILENO;
5947 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) 6362 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
5948 { 6363 {
5949 pointer args = NIL; 6364 pointer args = NIL;
… …
5967 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args); 6382 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
5968 6383
5969 } 6384 }
5970 else 6385 else
5971 fin = open (file_name, O_RDONLY); 6386 fin = open (file_name, O_RDONLY);
5972#endif
5973 6387
5974 if (isfile && fin < 0) 6388 if (isfile && fin < 0)
5975 { 6389 {
5976 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6390 putstr (SCHEME_A_ "Could not open file ");
6391 putstr (SCHEME_A_ file_name);
6392 putcharacter (SCHEME_A_ '\n');
5977 } 6393 }
5978 else 6394 else
5979 { 6395 {
5980 if (isfile) 6396 if (isfile)
5981 scheme_load_named_file (SCHEME_A_ fin, file_name); 6397 scheme_load_named_file (SCHEME_A_ fin, file_name);
5982 else 6398 else
5983 scheme_load_string (SCHEME_A_ file_name); 6399 scheme_load_string (SCHEME_A_ file_name);
5984 6400
5985#if USE_PORTS
5986 if (!isfile || fin != STDIN_FILENO) 6401 if (!isfile || fin != STDIN_FILENO)
5987 { 6402 {
5988 if (SCHEME_V->retcode != 0) 6403 if (SCHEME_V->retcode != 0)
5989 { 6404 {
5990 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6405 putstr (SCHEME_A_ "Errors encountered reading ");
6406 putstr (SCHEME_A_ file_name);
6407 putcharacter (SCHEME_A_ '\n');
5991 } 6408 }
5992 6409
5993 if (isfile) 6410 if (isfile)
5994 close (fin); 6411 close (fin);
5995 } 6412 }
5996#endif
5997 } 6413 }
5998 6414
5999 file_name = *argv++; 6415 file_name = *argv++;
6000 } 6416 }
6001 while (file_name != 0); 6417 while (file_name != 0);

Diff Legend

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