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.46 by root, Mon Nov 30 09:16:55 2015 UTC vs.
Revision 1.65 by root, Wed Dec 2 17:01:51 2015 UTC

… …
16 * (MINISCM) This is a revised and modified version by Akira KIDA. 16 * (MINISCM) This is a revised and modified version by Akira KIDA.
17 * (MINISCM) current version is 0.85k4 (15 May 1994) 17 * (MINISCM) current version is 0.85k4 (15 May 1994)
18 * 18 *
19 */ 19 */
20 20
21#define EXPERIMENT 1 21#define _POSIX_C_SOURCE 200201
22 22#define _XOPEN_SOURCE 600
23#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ 23#define _GNU_SOURCE 1 /* for malloc mremap */
24#include "malloc.c"
25 24
26#define SCHEME_SOURCE 25#define SCHEME_SOURCE
27#include "scheme-private.h" 26#include "scheme-private.h"
28#ifndef WIN32 27#ifndef WIN32
29# include <unistd.h> 28# include <unistd.h>
30#endif 29#endif
31#if USE_MATH 30#if USE_MATH
32# include <math.h> 31# include <math.h>
33#endif 32#endif
34 33
34#define ECB_NO_THREADS 1
35#include "ecb.h" 35#include "ecb.h"
36 36
37#include <sys/types.h> 37#include <sys/types.h>
38#include <sys/stat.h> 38#include <sys/stat.h>
39#include <fcntl.h> 39#include <fcntl.h>
… …
47#include <string.h> 47#include <string.h>
48 48
49#include <limits.h> 49#include <limits.h>
50#include <inttypes.h> 50#include <inttypes.h>
51#include <float.h> 51#include <float.h>
52//#include <ctype.h> 52
53#if !USE_SYSTEM_MALLOC
54# define PAGE_SIZE 4096 /* does not work on sparc/alpha */
55# include "malloc.c"
56# define malloc(n) tiny_malloc (n)
57# define realloc(p,n) tiny_realloc (p, n)
58# define free(p) tiny_free (p)
59#endif
53 60
54#if '1' != '0' + 1 \ 61#if '1' != '0' + 1 \
55 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \ 62 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
56 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \ 63 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
57 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \ 64 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
… …
79 86
80#define BACKQUOTE '`' 87#define BACKQUOTE '`'
81#define WHITESPACE " \t\r\n\v\f" 88#define WHITESPACE " \t\r\n\v\f"
82#define DELIMITERS "()\";" WHITESPACE 89#define DELIMITERS "()\";" WHITESPACE
83 90
84#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 91#define NIL POINTER (&SCHEME_V->xNIL)
85#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 92#define S_T POINTER (&SCHEME_V->xT)
86#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 93#define S_F POINTER (&SCHEME_V->xF)
87#define S_SINK (&SCHEME_V->xsink) 94#define S_SINK POINTER (&SCHEME_V->xsink)
88#define S_EOF (&SCHEME_V->xEOF_OBJ) 95#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
89 96
90#if !USE_MULTIPLICITY 97#if !USE_MULTIPLICITY
91static scheme sc; 98static scheme sc;
92#endif 99#endif
93 100
94static void 101ecb_cold static void
95xbase (char *s, long n, int base) 102xbase (char *s, long n, int base)
96{ 103{
97 if (n < 0) 104 if (n < 0)
98 { 105 {
99 *s++ = '-'; 106 *s++ = '-';
… …
101 } 108 }
102 109
103 char *p = s; 110 char *p = s;
104 111
105 do { 112 do {
106 *p++ = '0' + n % base; 113 *p++ = "0123456789abcdef"[n % base];
107 n /= base; 114 n /= base;
108 } while (n); 115 } while (n);
109 116
110 *p-- = 0; 117 *p-- = 0;
111 118
… …
114 char x = *s; *s = *p; *p = x; 121 char x = *s; *s = *p; *p = x;
115 --p; ++s; 122 --p; ++s;
116 } 123 }
117} 124}
118 125
119static void 126ecb_cold static void
120xnum (char *s, long n) 127xnum (char *s, long n)
121{ 128{
122 xbase (s, n, 10); 129 xbase (s, n, 10);
123} 130}
124 131
125static void 132ecb_cold static void
126xwrstr (const char *s) 133putnum (SCHEME_P_ long n)
127{
128 write (1, s, strlen (s));
129}
130
131static void
132xwrnum (long n)
133{ 134{
134 char buf[64]; 135 char buf[64];
135 136
136 xnum (buf, n); 137 xnum (buf, n);
137 xwrstr (buf); 138 putstr (SCHEME_A_ buf);
138} 139}
140
141#if USE_CHAR_CLASSIFIERS
142#include <ctype.h>
143#else
139 144
140static char 145static char
141xtoupper (char c) 146xtoupper (char c)
142{ 147{
143 if (c >= 'a' && c <= 'z') 148 if (c >= 'a' && c <= 'z')
… …
163 168
164#define toupper(c) xtoupper (c) 169#define toupper(c) xtoupper (c)
165#define tolower(c) xtolower (c) 170#define tolower(c) xtolower (c)
166#define isdigit(c) xisdigit (c) 171#define isdigit(c) xisdigit (c)
167 172
173#endif
174
168#if USE_IGNORECASE 175#if USE_IGNORECASE
169static const char * 176ecb_cold static const char *
170xstrlwr (char *s) 177xstrlwr (char *s)
171{ 178{
172 const char *p = s; 179 const char *p = s;
173 180
174 while (*s) 181 while (*s)
… …
187# define stricmp(a,b) strcmp (a, b) 194# define stricmp(a,b) strcmp (a, b)
188# define strlwr(s) (s) 195# define strlwr(s) (s)
189#endif 196#endif
190 197
191#ifndef prompt 198#ifndef prompt
192# define prompt "ts> " 199# define prompt "ms> "
193#endif 200#endif
194 201
195#ifndef InitFile 202#ifndef InitFile
196# define InitFile "init.scm" 203# define InitFile "init.scm"
197#endif 204#endif
198 205
199#ifndef FIRST_CELLSEGS
200# define FIRST_CELLSEGS 3
201#endif
202
203enum scheme_types 206enum scheme_types
204{ 207{
205 T_INTEGER, 208 T_INTEGER,
209 T_CHARACTER,
206 T_REAL, 210 T_REAL,
207 T_STRING, 211 T_STRING,
208 T_SYMBOL, 212 T_SYMBOL,
209 T_PROC, 213 T_PROC,
210 T_PAIR, /* also used for free cells */ 214 T_PAIR, /* also used for free cells */
211 T_CLOSURE, 215 T_CLOSURE,
216 T_BYTECODE, // temp
217 T_MACRO,
212 T_CONTINUATION, 218 T_CONTINUATION,
213 T_FOREIGN, 219 T_FOREIGN,
214 T_CHARACTER,
215 T_PORT, 220 T_PORT,
216 T_VECTOR, 221 T_VECTOR,
217 T_MACRO,
218 T_PROMISE, 222 T_PROMISE,
219 T_ENVIRONMENT, 223 T_ENVIRONMENT,
220 /* one more... */ 224
221 T_NUM_SYSTEM_TYPES 225 T_NUM_SYSTEM_TYPES
222}; 226};
223 227
224#define T_MASKTYPE 0x000f 228#define T_MASKTYPE 0x000f
225#define T_SYNTAX 0x0010 229#define T_SYNTAX 0x0010
… …
258static num num_op (enum num_op op, num a, num b); 262static num num_op (enum num_op op, num a, num b);
259static num num_intdiv (num a, num b); 263static num num_intdiv (num a, num b);
260static num num_rem (num a, num b); 264static num num_rem (num a, num b);
261static num num_mod (num a, num b); 265static num num_mod (num a, num b);
262 266
263#if USE_MATH
264static double round_per_R5RS (double x);
265#endif
266static int is_zero_rvalue (RVALUE x); 267static int is_zero_rvalue (RVALUE x);
267 268
268static num num_zero; 269static num num_zero;
269static num num_one; 270static num num_one;
270 271
272/* convert "pointer" to cell* / cell* to pointer */
273#define CELL(p) ((struct cell *)(p) + 0)
274#define POINTER(c) ((void *)((c) - 0))
275
271/* macros for cell operations */ 276/* macros for cell operations */
272#define typeflag(p) ((p)->flag + 0) 277#define typeflag(p) (CELL(p)->flag + 0)
273#define set_typeflag(p,v) ((p)->flag = (v)) 278#define set_typeflag(p,v) (CELL(p)->flag = (v))
274#define type(p) (typeflag (p) & T_MASKTYPE) 279#define type(p) (typeflag (p) & T_MASKTYPE)
275 280
276INTERFACE int 281INTERFACE int
277is_string (pointer p) 282is_string (pointer p)
278{ 283{
279 return type (p) == T_STRING; 284 return type (p) == T_STRING;
280} 285}
281 286
282#define strvalue(p) ((p)->object.string.svalue) 287#define strvalue(p) (CELL(p)->object.string.svalue)
283#define strlength(p) ((p)->object.string.length) 288#define strlength(p) (CELL(p)->object.string.length)
284 289
285INTERFACE int 290INTERFACE int
286is_vector (pointer p) 291is_vector (pointer p)
287{ 292{
288 return type (p) == T_VECTOR; 293 return type (p) == T_VECTOR;
289} 294}
290 295
291#define vecvalue(p) ((p)->object.vector.vvalue) 296#define vecvalue(p) (CELL(p)->object.vector.vvalue)
292#define veclength(p) ((p)->object.vector.length) 297#define veclength(p) (CELL(p)->object.vector.length)
293INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); 298INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
294INTERFACE pointer vector_get (pointer vec, uint32_t ielem); 299INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
295INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); 300INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
296 301
297INTERFACE int 302INTERFACE int
… …
323string_value (pointer p) 328string_value (pointer p)
324{ 329{
325 return strvalue (p); 330 return strvalue (p);
326} 331}
327 332
328#define ivalue_unchecked(p) (p)->object.ivalue 333#define ivalue_unchecked(p) CELL(p)->object.ivalue
329#define set_ivalue(p,v) (p)->object.ivalue = (v) 334#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
330 335
331#if USE_REAL 336#if USE_REAL
332#define rvalue_unchecked(p) (p)->object.rvalue 337#define rvalue_unchecked(p) CELL(p)->object.rvalue
333#define set_rvalue(p,v) (p)->object.rvalue = (v) 338#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
334#else 339#else
335#define rvalue_unchecked(p) (p)->object.ivalue 340#define rvalue_unchecked(p) CELL(p)->object.ivalue
336#define set_rvalue(p,v) (p)->object.ivalue = (v) 341#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
337#endif 342#endif
338 343
339INTERFACE long 344INTERFACE long
340charvalue (pointer p) 345charvalue (pointer p)
341{ 346{
342 return ivalue_unchecked (p); 347 return ivalue_unchecked (p);
343} 348}
344 349
350#define port(p) CELL(p)->object.port
351#define set_port(p,v) port(p) = (v)
345INTERFACE int 352INTERFACE int
346is_port (pointer p) 353is_port (pointer p)
347{ 354{
348 return type (p) == T_PORT; 355 return type (p) == T_PORT;
349} 356}
350 357
351INTERFACE int 358INTERFACE int
352is_inport (pointer p) 359is_inport (pointer p)
353{ 360{
354 return is_port (p) && p->object.port->kind & port_input; 361 return is_port (p) && port (p)->kind & port_input;
355} 362}
356 363
357INTERFACE int 364INTERFACE int
358is_outport (pointer p) 365is_outport (pointer p)
359{ 366{
360 return is_port (p) && p->object.port->kind & port_output; 367 return is_port (p) && port (p)->kind & port_output;
361} 368}
362 369
363INTERFACE int 370INTERFACE int
364is_pair (pointer p) 371is_pair (pointer p)
365{ 372{
366 return type (p) == T_PAIR; 373 return type (p) == T_PAIR;
367} 374}
368 375
369#define car(p) ((p)->object.cons.car + 0) 376#define car(p) (POINTER (CELL(p)->object.cons.car))
370#define cdr(p) ((p)->object.cons.cdr + 0) 377#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
371 378
372static pointer caar (pointer p) { return car (car (p)); } 379static pointer caar (pointer p) { return car (car (p)); }
373static pointer cadr (pointer p) { return car (cdr (p)); } 380static pointer cadr (pointer p) { return car (cdr (p)); }
374static pointer cdar (pointer p) { return cdr (car (p)); } 381static pointer cdar (pointer p) { return cdr (car (p)); }
375static pointer cddr (pointer p) { return cdr (cdr (p)); } 382static pointer cddr (pointer p) { return cdr (cdr (p)); }
376 383
377static pointer cadar (pointer p) { return car (cdr (car (p))); } 384static pointer cadar (pointer p) { return car (cdr (car (p))); }
378static pointer caddr (pointer p) { return car (cdr (cdr (p))); } 385static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
379static pointer cdaar (pointer p) { return cdr (car (car (p))); } 386static pointer cdaar (pointer p) { return cdr (car (car (p))); }
380 387
388static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); }
389
381INTERFACE void 390INTERFACE void
382set_car (pointer p, pointer q) 391set_car (pointer p, pointer q)
383{ 392{
384 p->object.cons.car = q; 393 CELL(p)->object.cons.car = CELL (q);
385} 394}
386 395
387INTERFACE void 396INTERFACE void
388set_cdr (pointer p, pointer q) 397set_cdr (pointer p, pointer q)
389{ 398{
390 p->object.cons.cdr = q; 399 CELL(p)->object.cons.cdr = CELL (q);
391} 400}
392 401
393INTERFACE pointer 402INTERFACE pointer
394pair_car (pointer p) 403pair_car (pointer p)
395{ 404{
… …
413{ 422{
414 return strvalue (p); 423 return strvalue (p);
415} 424}
416 425
417#if USE_PLIST 426#if USE_PLIST
427#error plists are broken because symbols are no longer pairs
418#define symprop(p) cdr(p) 428#define symprop(p) cdr(p)
419SCHEME_EXPORT int 429SCHEME_EXPORT int
420hasprop (pointer p) 430hasprop (pointer p)
421{ 431{
422 return typeflag (p) & T_SYMBOL; 432 return typeflag (p) & T_SYMBOL;
… …
524 proper list: length 534 proper list: length
525 circular list: -1 535 circular list: -1
526 not even a pair: -2 536 not even a pair: -2
527 dotted list: -2 minus length before dot 537 dotted list: -2 minus length before dot
528*/ 538*/
529INTERFACE int 539ecb_hot INTERFACE int
530list_length (SCHEME_P_ pointer a) 540list_length (SCHEME_P_ pointer a)
531{ 541{
532 int i = 0; 542 int i = 0;
533 pointer slow, fast; 543 pointer slow, fast;
534 544
… …
573{ 583{
574 return list_length (SCHEME_A_ a) >= 0; 584 return list_length (SCHEME_A_ a) >= 0;
575} 585}
576 586
577#if USE_CHAR_CLASSIFIERS 587#if USE_CHAR_CLASSIFIERS
588
578ecb_inline int 589ecb_inline int
579Cisalpha (int c) 590Cisalpha (int c)
580{ 591{
581 return isascii (c) && isalpha (c); 592 return isascii (c) && isalpha (c);
582} 593}
… …
640 "gs", 651 "gs",
641 "rs", 652 "rs",
642 "us" 653 "us"
643}; 654};
644 655
645static int 656ecb_cold static int
646is_ascii_name (const char *name, int *pc) 657is_ascii_name (const char *name, int *pc)
647{ 658{
648 int i; 659 int i;
649 660
650 for (i = 0; i < 32; i++) 661 for (i = 0; i < 32; i++)
… …
669 680
670static int file_push (SCHEME_P_ const char *fname); 681static int file_push (SCHEME_P_ const char *fname);
671static void file_pop (SCHEME_P); 682static void file_pop (SCHEME_P);
672static int file_interactive (SCHEME_P); 683static int file_interactive (SCHEME_P);
673ecb_inline int is_one_of (const char *s, int c); 684ecb_inline int is_one_of (const char *s, int c);
674static int alloc_cellseg (SCHEME_P_ int n); 685static int alloc_cellseg (SCHEME_P);
675ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 686ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
676static void finalize_cell (SCHEME_P_ pointer a); 687static void finalize_cell (SCHEME_P_ pointer a);
677static int count_consecutive_cells (pointer x, int needed);
678static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 688static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
679static pointer mk_number (SCHEME_P_ const num n); 689static pointer mk_number (SCHEME_P_ const num n);
680static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 690static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
681static pointer mk_vector (SCHEME_P_ uint32_t len); 691static pointer mk_vector (SCHEME_P_ uint32_t len);
682static pointer mk_atom (SCHEME_P_ char *q); 692static pointer mk_atom (SCHEME_P_ char *q);
683static pointer mk_sharp_const (SCHEME_P_ char *name); 693static pointer mk_sharp_const (SCHEME_P_ char *name);
684 694
695static pointer mk_port (SCHEME_P_ port *p);
696
685#if USE_PORTS 697#if USE_PORTS
686static pointer mk_port (SCHEME_P_ port *p);
687static pointer port_from_filename (SCHEME_P_ const char *fn, int prop); 698static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
688static pointer port_from_file (SCHEME_P_ int, int prop); 699static pointer port_from_file (SCHEME_P_ int, int prop);
689static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 700static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
690static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop); 701static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop);
691static port *port_rep_from_file (SCHEME_P_ int, int prop); 702static port *port_rep_from_file (SCHEME_P_ int, int prop);
692static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 703static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
693static void port_close (SCHEME_P_ pointer p, int flag); 704static void port_close (SCHEME_P_ pointer p, int flag);
694#endif 705#endif
706
695static void mark (pointer a); 707static void mark (pointer a);
696static void gc (SCHEME_P_ pointer a, pointer b); 708static void gc (SCHEME_P_ pointer a, pointer b);
697static int basic_inchar (port *pt); 709static int basic_inchar (port *pt);
698static int inchar (SCHEME_P); 710static int inchar (SCHEME_P);
699static void backchar (SCHEME_P_ int c); 711static void backchar (SCHEME_P_ int c);
700static char *readstr_upto (SCHEME_P_ int skip, const char *delim); 712static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
701static pointer readstrexp (SCHEME_P_ char delim); 713static pointer readstrexp (SCHEME_P_ char delim);
702ecb_inline int skipspace (SCHEME_P); 714static int skipspace (SCHEME_P);
703static int token (SCHEME_P); 715static int token (SCHEME_P);
704static void printslashstring (SCHEME_P_ char *s, int len); 716static void printslashstring (SCHEME_P_ char *s, int len);
705static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 717static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
706static void printatom (SCHEME_P_ pointer l, int f); 718static void printatom (SCHEME_P_ pointer l, int f);
707static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 719static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
873 } 885 }
874 886
875 return ret; 887 return ret;
876} 888}
877 889
878#if USE_MATH
879
880/* Round to nearest. Round to even if midway */
881static double
882round_per_R5RS (double x)
883{
884 double fl = floor (x);
885 double ce = ceil (x);
886 double dfl = x - fl;
887 double dce = ce - x;
888
889 if (dfl > dce)
890 return ce;
891 else if (dfl < dce)
892 return fl;
893 else
894 {
895 if (fmod (fl, 2) == 0) /* I imagine this holds */
896 return fl;
897 else
898 return ce;
899 }
900}
901#endif
902
903static int 890static int
904is_zero_rvalue (RVALUE x) 891is_zero_rvalue (RVALUE x)
905{ 892{
906 return x == 0; 893 return x == 0;
907#if 0 894#if 0
… …
912#endif 899#endif
913#endif 900#endif
914} 901}
915 902
916/* allocate new cell segment */ 903/* allocate new cell segment */
917static int 904ecb_cold static int
918alloc_cellseg (SCHEME_P_ int n) 905alloc_cellseg (SCHEME_P)
919{ 906{
920 pointer newp; 907 struct cell *newp;
921 pointer last; 908 struct cell *last;
922 pointer p; 909 struct cell *p;
923 char *cp; 910 char *cp;
924 long i; 911 long i;
925 int k; 912 int k;
926 913
927 static int segsize = CELL_SEGSIZE >> 1; 914 static int segsize = CELL_SEGSIZE >> 1;
928 segsize <<= 1; 915 segsize <<= 1;
929 916
930 for (k = 0; k < n; k++)
931 {
932 if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
933 return k;
934
935 cp = malloc (segsize * sizeof (struct cell)); 917 cp = malloc (segsize * sizeof (struct cell));
936 918
937 if (!cp && USE_ERROR_CHECKING) 919 if (!cp && USE_ERROR_CHECKING)
938 return k; 920 return k;
939 921
940 i = ++SCHEME_V->last_cell_seg; 922 i = ++SCHEME_V->last_cell_seg;
941 SCHEME_V->alloc_seg[i] = cp;
942 923
943 newp = (pointer)cp; 924 newp = (struct cell *)cp;
944 SCHEME_V->cell_seg[i] = newp; 925 SCHEME_V->cell_seg[i] = newp;
945 SCHEME_V->cell_segsize[i] = segsize; 926 SCHEME_V->cell_segsize[i] = segsize;
946 SCHEME_V->fcells += segsize; 927 SCHEME_V->fcells += segsize;
947 last = newp + segsize - 1; 928 last = newp + segsize - 1;
948 929
949 for (p = newp; p <= last; p++) 930 for (p = newp; p <= last; p++)
950 { 931 {
932 pointer cp = POINTER (p);
951 set_typeflag (p, T_PAIR); 933 set_typeflag (cp, T_PAIR);
952 set_car (p, NIL); 934 set_car (cp, NIL);
953 set_cdr (p, p + 1); 935 set_cdr (cp, POINTER (p + 1));
954 } 936 }
955 937
956 set_cdr (last, SCHEME_V->free_cell); 938 set_cdr (POINTER (last), SCHEME_V->free_cell);
957 SCHEME_V->free_cell = newp; 939 SCHEME_V->free_cell = POINTER (newp);
958 }
959 940
960 return n; 941 return 1;
961} 942}
962 943
963/* get new cell. parameter a, b is marked by gc. */ 944/* get new cell. parameter a, b is marked by gc. */
964ecb_inline pointer 945ecb_inline pointer
965get_cell_x (SCHEME_P_ pointer a, pointer b) 946get_cell_x (SCHEME_P_ pointer a, pointer b)
… …
969 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 950 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
970 return S_SINK; 951 return S_SINK;
971 952
972 if (SCHEME_V->free_cell == NIL) 953 if (SCHEME_V->free_cell == NIL)
973 { 954 {
974 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1; 955 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
975 956
976 gc (SCHEME_A_ a, b); 957 gc (SCHEME_A_ a, b);
977 958
978 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 959 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
979 { 960 {
980 /* if only a few recovered, get more to avoid fruitless gc's */ 961 /* if only a few recovered, get more to avoid fruitless gc's */
981 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 962 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
982 { 963 {
983#if USE_ERROR_CHECKING 964#if USE_ERROR_CHECKING
984 SCHEME_V->no_memory = 1; 965 SCHEME_V->no_memory = 1;
985 return S_SINK; 966 return S_SINK;
986#endif 967#endif
… …
998 } 979 }
999} 980}
1000 981
1001/* To retain recent allocs before interpreter knows about them - 982/* To retain recent allocs before interpreter knows about them -
1002 Tehom */ 983 Tehom */
1003 984ecb_hot static void
1004static void
1005push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 985push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1006{ 986{
1007 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 987 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1008 988
1009 set_typeflag (holder, T_PAIR); 989 set_typeflag (holder, T_PAIR);
… …
1011 set_car (holder, recent); 991 set_car (holder, recent);
1012 set_cdr (holder, car (S_SINK)); 992 set_cdr (holder, car (S_SINK));
1013 set_car (S_SINK, holder); 993 set_car (S_SINK, holder);
1014} 994}
1015 995
1016static pointer 996ecb_hot static pointer
1017get_cell (SCHEME_P_ pointer a, pointer b) 997get_cell (SCHEME_P_ pointer a, pointer b)
1018{ 998{
1019 pointer cell = get_cell_x (SCHEME_A_ a, b); 999 pointer cell = get_cell_x (SCHEME_A_ a, b);
1020 1000
1021 /* For right now, include "a" and "b" in "cell" so that gc doesn't 1001 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1039 return S_SINK; 1019 return S_SINK;
1040 1020
1041 /* Record it as a vector so that gc understands it. */ 1021 /* Record it as a vector so that gc understands it. */
1042 set_typeflag (v, T_VECTOR | T_ATOM); 1022 set_typeflag (v, T_VECTOR | T_ATOM);
1043 1023
1044 v->object.vector.vvalue = e; 1024 CELL(v)->object.vector.vvalue = e;
1045 v->object.vector.length = len; 1025 CELL(v)->object.vector.length = len;
1046 fill_vector (v, 0, init); 1026 fill_vector (v, 0, init);
1047 push_recent_alloc (SCHEME_A_ v, NIL); 1027 push_recent_alloc (SCHEME_A_ v, NIL);
1048 1028
1049 return v; 1029 return v;
1050} 1030}
… …
1059static void 1039static void
1060check_cell_alloced (pointer p, int expect_alloced) 1040check_cell_alloced (pointer p, int expect_alloced)
1061{ 1041{
1062 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ 1042 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1063 if (typeflag (p) & !expect_alloced) 1043 if (typeflag (p) & !expect_alloced)
1064 xwrstr ("Cell is already allocated!\n"); 1044 putstr (SCHEME_A_ "Cell is already allocated!\n");
1065 1045
1066 if (!(typeflag (p)) & expect_alloced) 1046 if (!(typeflag (p)) & expect_alloced)
1067 xwrstr ("Cell is not allocated!\n"); 1047 putstr (SCHEME_A_ "Cell is not allocated!\n");
1068} 1048}
1069 1049
1070static void 1050static void
1071check_range_alloced (pointer p, int n, int expect_alloced) 1051check_range_alloced (pointer p, int n, int expect_alloced)
1072{ 1052{
… …
1078#endif 1058#endif
1079 1059
1080/* Medium level cell allocation */ 1060/* Medium level cell allocation */
1081 1061
1082/* get new cons cell */ 1062/* get new cons cell */
1083pointer 1063ecb_hot static pointer
1084xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1064xcons (SCHEME_P_ pointer a, pointer b)
1085{ 1065{
1086 pointer x = get_cell (SCHEME_A_ a, b); 1066 pointer x = get_cell (SCHEME_A_ a, b);
1087 1067
1088 set_typeflag (x, T_PAIR); 1068 set_typeflag (x, T_PAIR);
1089
1090 if (immutable)
1091 setimmutable (x);
1092 1069
1093 set_car (x, a); 1070 set_car (x, a);
1094 set_cdr (x, b); 1071 set_cdr (x, b);
1095 1072
1096 return x; 1073 return x;
1097} 1074}
1098 1075
1099static pointer 1076ecb_hot static pointer
1077ximmutable_cons (SCHEME_P_ pointer a, pointer b)
1078{
1079 pointer x = xcons (SCHEME_A_ a, b);
1080 setimmutable (x);
1081 return x;
1082}
1083
1084#define cons(a,b) xcons (SCHEME_A_ a, b)
1085#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1086
1087ecb_cold static pointer
1100generate_symbol (SCHEME_P_ const char *name) 1088generate_symbol (SCHEME_P_ const char *name)
1101{ 1089{
1102 pointer x = mk_string (SCHEME_A_ name); 1090 pointer x = mk_string (SCHEME_A_ name);
1103 setimmutable (x); 1091 setimmutable (x);
1104 set_typeflag (x, T_SYMBOL | T_ATOM); 1092 set_typeflag (x, T_SYMBOL | T_ATOM);
… …
1110#ifndef USE_OBJECT_LIST 1098#ifndef USE_OBJECT_LIST
1111 1099
1112static int 1100static int
1113hash_fn (const char *key, int table_size) 1101hash_fn (const char *key, int table_size)
1114{ 1102{
1115 const unsigned char *p = key; 1103 const unsigned char *p = (unsigned char *)key;
1116 uint32_t hash = 2166136261; 1104 uint32_t hash = 2166136261U;
1117 1105
1118 while (*p) 1106 while (*p)
1119 hash = (hash ^ *p++) * 16777619; 1107 hash = (hash ^ *p++) * 16777619;
1120 1108
1121 return hash % table_size; 1109 return hash % table_size;
1122} 1110}
1123 1111
1124static pointer 1112ecb_cold static pointer
1125oblist_initial_value (SCHEME_P) 1113oblist_initial_value (SCHEME_P)
1126{ 1114{
1127 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1115 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1128} 1116}
1129 1117
1130/* returns the new symbol */ 1118/* returns the new symbol */
1131static pointer 1119ecb_cold static pointer
1132oblist_add_by_name (SCHEME_P_ const char *name) 1120oblist_add_by_name (SCHEME_P_ const char *name)
1133{ 1121{
1134 pointer x = generate_symbol (SCHEME_A_ name); 1122 pointer x = generate_symbol (SCHEME_A_ name);
1135 int location = hash_fn (name, veclength (SCHEME_V->oblist)); 1123 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1136 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); 1124 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1137 return x; 1125 return x;
1138} 1126}
1139 1127
1140ecb_inline pointer 1128ecb_cold static pointer
1141oblist_find_by_name (SCHEME_P_ const char *name) 1129oblist_find_by_name (SCHEME_P_ const char *name)
1142{ 1130{
1143 int location; 1131 int location;
1144 pointer x; 1132 pointer x;
1145 char *s; 1133 char *s;
… …
1156 } 1144 }
1157 1145
1158 return NIL; 1146 return NIL;
1159} 1147}
1160 1148
1161static pointer 1149ecb_cold static pointer
1162oblist_all_symbols (SCHEME_P) 1150oblist_all_symbols (SCHEME_P)
1163{ 1151{
1164 int i; 1152 int i;
1165 pointer x; 1153 pointer x;
1166 pointer ob_list = NIL; 1154 pointer ob_list = NIL;
… …
1172 return ob_list; 1160 return ob_list;
1173} 1161}
1174 1162
1175#else 1163#else
1176 1164
1177static pointer 1165ecb_cold static pointer
1178oblist_initial_value (SCHEME_P) 1166oblist_initial_value (SCHEME_P)
1179{ 1167{
1180 return NIL; 1168 return NIL;
1181} 1169}
1182 1170
1183ecb_inline pointer 1171ecb_cold static pointer
1184oblist_find_by_name (SCHEME_P_ const char *name) 1172oblist_find_by_name (SCHEME_P_ const char *name)
1185{ 1173{
1186 pointer x; 1174 pointer x;
1187 char *s; 1175 char *s;
1188 1176
… …
1197 1185
1198 return NIL; 1186 return NIL;
1199} 1187}
1200 1188
1201/* returns the new symbol */ 1189/* returns the new symbol */
1202static pointer 1190ecb_cold static pointer
1203oblist_add_by_name (SCHEME_P_ const char *name) 1191oblist_add_by_name (SCHEME_P_ const char *name)
1204{ 1192{
1205 pointer x = mk_string (SCHEME_A_ name); 1193 pointer x = generate_symbol (SCHEME_A_ name);
1206 set_typeflag (x, T_SYMBOL);
1207 setimmutable (x);
1208 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1194 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1209 return x; 1195 return x;
1210} 1196}
1211 1197
1212static pointer 1198ecb_cold static pointer
1213oblist_all_symbols (SCHEME_P) 1199oblist_all_symbols (SCHEME_P)
1214{ 1200{
1215 return SCHEME_V->oblist; 1201 return SCHEME_V->oblist;
1216} 1202}
1217 1203
1218#endif 1204#endif
1219 1205
1220#if USE_PORTS
1221static pointer 1206ecb_cold static pointer
1222mk_port (SCHEME_P_ port *p) 1207mk_port (SCHEME_P_ port *p)
1223{ 1208{
1224 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1209 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1225 1210
1226 set_typeflag (x, T_PORT | T_ATOM); 1211 set_typeflag (x, T_PORT | T_ATOM);
1227 x->object.port = p; 1212 set_port (x, p);
1228 1213
1229 return x; 1214 return x;
1230} 1215}
1231#endif
1232 1216
1233pointer 1217ecb_cold pointer
1234mk_foreign_func (SCHEME_P_ foreign_func f) 1218mk_foreign_func (SCHEME_P_ foreign_func f)
1235{ 1219{
1236 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1220 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1237 1221
1238 set_typeflag (x, (T_FOREIGN | T_ATOM)); 1222 set_typeflag (x, T_FOREIGN | T_ATOM);
1239 x->object.ff = f; 1223 CELL(x)->object.ff = f;
1240 1224
1241 return x; 1225 return x;
1242} 1226}
1243 1227
1244INTERFACE pointer 1228INTERFACE pointer
1245mk_character (SCHEME_P_ int c) 1229mk_character (SCHEME_P_ int c)
1246{ 1230{
1247 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1231 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1248 1232
1249 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1233 set_typeflag (x, T_CHARACTER | T_ATOM);
1250 set_ivalue (x, c & 0xff); 1234 set_ivalue (x, c & 0xff);
1251 1235
1252 return x; 1236 return x;
1253} 1237}
1254 1238
1255/* get number atom (integer) */ 1239/* get number atom (integer) */
1256INTERFACE pointer 1240INTERFACE pointer
1257mk_integer (SCHEME_P_ long n) 1241mk_integer (SCHEME_P_ long n)
1258{ 1242{
1243 pointer p = 0;
1244 pointer *pp = &p;
1245
1246#if USE_INTCACHE
1247 if (n >= INTCACHE_MIN && n <= INTCACHE_MAX)
1248 pp = &SCHEME_V->intcache[n - INTCACHE_MIN];
1249#endif
1250
1251 if (!*pp)
1252 {
1259 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1253 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1260 1254
1261 set_typeflag (x, (T_INTEGER | T_ATOM)); 1255 set_typeflag (x, T_INTEGER | T_ATOM);
1256 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
1262 set_ivalue (x, n); 1257 set_ivalue (x, n);
1263 1258
1259 *pp = x;
1260 }
1261
1264 return x; 1262 return *pp;
1265} 1263}
1266 1264
1267INTERFACE pointer 1265INTERFACE pointer
1268mk_real (SCHEME_P_ RVALUE n) 1266mk_real (SCHEME_P_ RVALUE n)
1269{ 1267{
1270#if USE_REAL 1268#if USE_REAL
1271 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1269 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1272 1270
1273 set_typeflag (x, (T_REAL | T_ATOM)); 1271 set_typeflag (x, T_REAL | T_ATOM);
1274 set_rvalue (x, n); 1272 set_rvalue (x, n);
1275 1273
1276 return x; 1274 return x;
1277#else 1275#else
1278 return mk_integer (SCHEME_A_ n); 1276 return mk_integer (SCHEME_A_ n);
… …
1389 x = oblist_add_by_name (SCHEME_A_ name); 1387 x = oblist_add_by_name (SCHEME_A_ name);
1390 1388
1391 return x; 1389 return x;
1392} 1390}
1393 1391
1394INTERFACE pointer 1392ecb_cold INTERFACE pointer
1395gensym (SCHEME_P) 1393gensym (SCHEME_P)
1396{ 1394{
1397 pointer x; 1395 pointer x;
1398 char name[40] = "gensym-"; 1396 char name[40] = "gensym-";
1399 xnum (name + 7, ++SCHEME_V->gensym_cnt); 1397 xnum (name + 7, ++SCHEME_V->gensym_cnt);
… …
1406{ 1404{
1407 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; 1405 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1408} 1406}
1409 1407
1410/* make symbol or number atom from string */ 1408/* make symbol or number atom from string */
1411static pointer 1409ecb_cold static pointer
1412mk_atom (SCHEME_P_ char *q) 1410mk_atom (SCHEME_P_ char *q)
1413{ 1411{
1414 char c, *p; 1412 char c, *p;
1415 int has_dec_point = 0; 1413 int has_dec_point = 0;
1416 int has_fp_exp = 0; 1414 int has_fp_exp = 0;
… …
1487 1485
1488 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1486 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1489} 1487}
1490 1488
1491/* make constant */ 1489/* make constant */
1492static pointer 1490ecb_cold static pointer
1493mk_sharp_const (SCHEME_P_ char *name) 1491mk_sharp_const (SCHEME_P_ char *name)
1494{ 1492{
1495 if (!strcmp (name, "t")) 1493 if (!strcmp (name, "t"))
1496 return S_T; 1494 return S_T;
1497 else if (!strcmp (name, "f")) 1495 else if (!strcmp (name, "f"))
1498 return S_F; 1496 return S_F;
1499 else if (*name == '\\') /* #\w (character) */ 1497 else if (*name == '\\') /* #\w (character) */
1500 { 1498 {
1501 int c; 1499 int c;
1502 1500
1501 // TODO: optimise
1503 if (stricmp (name + 1, "space") == 0) 1502 if (stricmp (name + 1, "space") == 0)
1504 c = ' '; 1503 c = ' ';
1505 else if (stricmp (name + 1, "newline") == 0) 1504 else if (stricmp (name + 1, "newline") == 0)
1506 c = '\n'; 1505 c = '\n';
1507 else if (stricmp (name + 1, "return") == 0) 1506 else if (stricmp (name + 1, "return") == 0)
1508 c = '\r'; 1507 c = '\r';
1509 else if (stricmp (name + 1, "tab") == 0) 1508 else if (stricmp (name + 1, "tab") == 0)
1510 c = '\t'; 1509 c = '\t';
1510 else if (stricmp (name + 1, "alarm") == 0)
1511 c = 0x07;
1512 else if (stricmp (name + 1, "backspace") == 0)
1513 c = 0x08;
1514 else if (stricmp (name + 1, "escape") == 0)
1515 c = 0x1b;
1516 else if (stricmp (name + 1, "delete") == 0)
1517 c = 0x7f;
1518 else if (stricmp (name + 1, "null") == 0)
1519 c = 0;
1511 else if (name[1] == 'x' && name[2] != 0) 1520 else if (name[1] == 'x' && name[2] != 0)
1512 { 1521 {
1513 long c1 = strtol (name + 2, 0, 16); 1522 long c1 = strtol (name + 2, 0, 16);
1514 1523
1515 if (0 <= c1 && c1 <= UCHAR_MAX) 1524 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1540 return NIL; 1549 return NIL;
1541 } 1550 }
1542} 1551}
1543 1552
1544/* ========== garbage collector ========== */ 1553/* ========== garbage collector ========== */
1554
1555static void
1556finalize_cell (SCHEME_P_ pointer a)
1557{
1558 /* TODO, fast bitmap check? */
1559 if (is_string (a) || is_symbol (a))
1560 free (strvalue (a));
1561 else if (is_vector (a))
1562 free (vecvalue (a));
1563#if USE_PORTS
1564 else if (is_port (a))
1565 {
1566 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1567 port_close (SCHEME_A_ a, port_input | port_output);
1568
1569 free (port (a));
1570 }
1571#endif
1572}
1545 1573
1546/*-- 1574/*--
1547 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1575 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1548 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1576 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1549 * for marking. 1577 * for marking.
1550 * 1578 *
1551 * The exception is vectors - vectors are currently marked recursively, 1579 * The exception is vectors - vectors are currently marked recursively,
1552 * which is inherited form tinyscheme and could be fixed by having another 1580 * which is inherited form tinyscheme and could be fixed by having another
1553 * word of context in the vector 1581 * word of context in the vector
1554 */ 1582 */
1555static void 1583ecb_hot static void
1556mark (pointer a) 1584mark (pointer a)
1557{ 1585{
1558 pointer t, q, p; 1586 pointer t, q, p;
1559 1587
1560 t = 0; 1588 t = 0;
… …
1617 p = q; 1645 p = q;
1618 goto E6; 1646 goto E6;
1619 } 1647 }
1620} 1648}
1621 1649
1650ecb_hot static void
1651gc_free (SCHEME_P)
1652{
1653 int i;
1654 uint32_t total = 0;
1655
1656 /* Here we scan the cells to build the free-list. */
1657 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1658 {
1659 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1660 struct cell *p;
1661 total += SCHEME_V->cell_segsize [i];
1662
1663 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1664 {
1665 pointer c = POINTER (p);
1666
1667 if (is_mark (c))
1668 clrmark (c);
1669 else
1670 {
1671 /* reclaim cell */
1672 if (typeflag (c) != T_PAIR)
1673 {
1674 finalize_cell (SCHEME_A_ c);
1675 set_typeflag (c, T_PAIR);
1676 set_car (c, NIL);
1677 }
1678
1679 ++SCHEME_V->fcells;
1680 set_cdr (c, SCHEME_V->free_cell);
1681 SCHEME_V->free_cell = c;
1682 }
1683 }
1684 }
1685
1686 if (SCHEME_V->gc_verbose)
1687 {
1688 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");
1689 }
1690}
1691
1622/* garbage collection. parameter a, b is marked. */ 1692/* garbage collection. parameter a, b is marked. */
1623static void 1693ecb_cold static void
1624gc (SCHEME_P_ pointer a, pointer b) 1694gc (SCHEME_P_ pointer a, pointer b)
1625{ 1695{
1626 pointer p;
1627 int i; 1696 int i;
1628 1697
1629 if (SCHEME_V->gc_verbose) 1698 if (SCHEME_V->gc_verbose)
1630 putstr (SCHEME_A_ "gc..."); 1699 putstr (SCHEME_A_ "gc...");
1631 1700
… …
1647 /* Mark recent objects the interpreter doesn't know about yet. */ 1716 /* Mark recent objects the interpreter doesn't know about yet. */
1648 mark (car (S_SINK)); 1717 mark (car (S_SINK));
1649 /* Mark any older stuff above nested C calls */ 1718 /* Mark any older stuff above nested C calls */
1650 mark (SCHEME_V->c_nest); 1719 mark (SCHEME_V->c_nest);
1651 1720
1721#if USE_INTCACHE
1722 /* mark intcache */
1723 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1724 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1725 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1726#endif
1727
1652 /* mark variables a, b */ 1728 /* mark variables a, b */
1653 mark (a); 1729 mark (a);
1654 mark (b); 1730 mark (b);
1655 1731
1656 /* garbage collect */ 1732 /* garbage collect */
1657 clrmark (NIL); 1733 clrmark (NIL);
1658 SCHEME_V->fcells = 0; 1734 SCHEME_V->fcells = 0;
1659 SCHEME_V->free_cell = NIL; 1735 SCHEME_V->free_cell = NIL;
1660 1736
1661 if (SCHEME_V->gc_verbose) 1737 if (SCHEME_V->gc_verbose)
1662 xwrstr ("freeing..."); 1738 putstr (SCHEME_A_ "freeing...");
1663 1739
1664 uint32_t total = 0; 1740 gc_free (SCHEME_A);
1665
1666 /* Here we scan the cells to build the free-list. */
1667 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1668 {
1669 pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1670 total += SCHEME_V->cell_segsize [i];
1671
1672 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1673 {
1674 if (is_mark (p))
1675 clrmark (p);
1676 else
1677 {
1678 /* reclaim cell */
1679 if (typeflag (p) != T_PAIR)
1680 {
1681 finalize_cell (SCHEME_A_ p);
1682 set_typeflag (p, T_PAIR);
1683 set_car (p, NIL);
1684 }
1685
1686 ++SCHEME_V->fcells;
1687 set_cdr (p, SCHEME_V->free_cell);
1688 SCHEME_V->free_cell = p;
1689 }
1690 }
1691 }
1692
1693 if (SCHEME_V->gc_verbose)
1694 {
1695 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n");
1696 }
1697}
1698
1699static void
1700finalize_cell (SCHEME_P_ pointer a)
1701{
1702 /* TODO, fast bitmap check? */
1703 if (is_string (a) || is_symbol (a))
1704 free (strvalue (a));
1705 else if (is_vector (a))
1706 free (vecvalue (a));
1707#if USE_PORTS
1708 else if (is_port (a))
1709 {
1710 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1711 port_close (SCHEME_A_ a, port_input | port_output);
1712
1713 free (a->object.port);
1714 }
1715#endif
1716} 1741}
1717 1742
1718/* ========== Routines for Reading ========== */ 1743/* ========== Routines for Reading ========== */
1719 1744
1720static int 1745ecb_cold static int
1721file_push (SCHEME_P_ const char *fname) 1746file_push (SCHEME_P_ const char *fname)
1722{ 1747{
1723#if USE_PORTS
1724 int fin; 1748 int fin;
1725 1749
1726 if (SCHEME_V->file_i == MAXFIL - 1) 1750 if (SCHEME_V->file_i == MAXFIL - 1)
1727 return 0; 1751 return 0;
1728 1752
… …
1734 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1758 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1735 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1759 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1736 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; 1760 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1737 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; 1761 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1738 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1762 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1739 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1763 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1740 1764
1741#if SHOW_ERROR_LINE 1765#if SHOW_ERROR_LINE
1742 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1766 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1743 1767
1744 if (fname) 1768 if (fname)
1745 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0); 1769 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1746#endif 1770#endif
1747 } 1771 }
1748 1772
1749 return fin >= 0; 1773 return fin >= 0;
1750
1751#else
1752 return 1;
1753#endif
1754} 1774}
1755 1775
1756static void 1776ecb_cold static void
1757file_pop (SCHEME_P) 1777file_pop (SCHEME_P)
1758{ 1778{
1759 if (SCHEME_V->file_i != 0) 1779 if (SCHEME_V->file_i != 0)
1760 { 1780 {
1761 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1781 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1762#if USE_PORTS 1782#if USE_PORTS
1763 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1783 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1764#endif 1784#endif
1765 SCHEME_V->file_i--; 1785 SCHEME_V->file_i--;
1766 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1786 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1767 } 1787 }
1768} 1788}
1769 1789
1770static int 1790ecb_cold static int
1771file_interactive (SCHEME_P) 1791file_interactive (SCHEME_P)
1772{ 1792{
1773#if USE_PORTS 1793#if USE_PORTS
1774 return SCHEME_V->file_i == 0 1794 return SCHEME_V->file_i == 0
1775 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1795 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1776 && (SCHEME_V->inport->object.port->kind & port_file); 1796 && (port (SCHEME_V->inport)->kind & port_file);
1777#else 1797#else
1778 return 0; 1798 return 0;
1779#endif 1799#endif
1780} 1800}
1781 1801
1782#if USE_PORTS 1802#if USE_PORTS
1783static port * 1803ecb_cold static port *
1784port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1804port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1785{ 1805{
1786 int fd; 1806 int fd;
1787 int flags; 1807 int flags;
1788 char *rw; 1808 char *rw;
… …
1811# endif 1831# endif
1812 1832
1813 return pt; 1833 return pt;
1814} 1834}
1815 1835
1816static pointer 1836ecb_cold static pointer
1817port_from_filename (SCHEME_P_ const char *fn, int prop) 1837port_from_filename (SCHEME_P_ const char *fn, int prop)
1818{ 1838{
1819 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1839 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1820 1840
1821 if (!pt && USE_ERROR_CHECKING) 1841 if (!pt && USE_ERROR_CHECKING)
1822 return NIL; 1842 return NIL;
1823 1843
1824 return mk_port (SCHEME_A_ pt); 1844 return mk_port (SCHEME_A_ pt);
1825} 1845}
1826 1846
1827static port * 1847ecb_cold static port *
1828port_rep_from_file (SCHEME_P_ int f, int prop) 1848port_rep_from_file (SCHEME_P_ int f, int prop)
1829{ 1849{
1830 port *pt = malloc (sizeof *pt); 1850 port *pt = malloc (sizeof *pt);
1831 1851
1832 if (!pt && USE_ERROR_CHECKING) 1852 if (!pt && USE_ERROR_CHECKING)
… …
1837 pt->rep.stdio.file = f; 1857 pt->rep.stdio.file = f;
1838 pt->rep.stdio.closeit = 0; 1858 pt->rep.stdio.closeit = 0;
1839 return pt; 1859 return pt;
1840} 1860}
1841 1861
1842static pointer 1862ecb_cold static pointer
1843port_from_file (SCHEME_P_ int f, int prop) 1863port_from_file (SCHEME_P_ int f, int prop)
1844{ 1864{
1845 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1865 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1846 1866
1847 if (!pt && USE_ERROR_CHECKING) 1867 if (!pt && USE_ERROR_CHECKING)
1848 return NIL; 1868 return NIL;
1849 1869
1850 return mk_port (SCHEME_A_ pt); 1870 return mk_port (SCHEME_A_ pt);
1851} 1871}
1852 1872
1853static port * 1873ecb_cold static port *
1854port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1874port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1855{ 1875{
1856 port *pt = malloc (sizeof (port)); 1876 port *pt = malloc (sizeof (port));
1857 1877
1858 if (!pt && USE_ERROR_CHECKING) 1878 if (!pt && USE_ERROR_CHECKING)
… …
1864 pt->rep.string.curr = start; 1884 pt->rep.string.curr = start;
1865 pt->rep.string.past_the_end = past_the_end; 1885 pt->rep.string.past_the_end = past_the_end;
1866 return pt; 1886 return pt;
1867} 1887}
1868 1888
1869static pointer 1889ecb_cold static pointer
1870port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1890port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1871{ 1891{
1872 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1892 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1873 1893
1874 if (!pt && USE_ERROR_CHECKING) 1894 if (!pt && USE_ERROR_CHECKING)
… …
1877 return mk_port (SCHEME_A_ pt); 1897 return mk_port (SCHEME_A_ pt);
1878} 1898}
1879 1899
1880# define BLOCK_SIZE 256 1900# define BLOCK_SIZE 256
1881 1901
1882static port * 1902ecb_cold static port *
1883port_rep_from_scratch (SCHEME_P) 1903port_rep_from_scratch (SCHEME_P)
1884{ 1904{
1885 char *start; 1905 char *start;
1886 port *pt = malloc (sizeof (port)); 1906 port *pt = malloc (sizeof (port));
1887 1907
… …
1901 pt->rep.string.curr = start; 1921 pt->rep.string.curr = start;
1902 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1922 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1903 return pt; 1923 return pt;
1904} 1924}
1905 1925
1906static pointer 1926ecb_cold static pointer
1907port_from_scratch (SCHEME_P) 1927port_from_scratch (SCHEME_P)
1908{ 1928{
1909 port *pt = port_rep_from_scratch (SCHEME_A); 1929 port *pt = port_rep_from_scratch (SCHEME_A);
1910 1930
1911 if (!pt && USE_ERROR_CHECKING) 1931 if (!pt && USE_ERROR_CHECKING)
1912 return NIL; 1932 return NIL;
1913 1933
1914 return mk_port (SCHEME_A_ pt); 1934 return mk_port (SCHEME_A_ pt);
1915} 1935}
1916 1936
1917static void 1937ecb_cold static void
1918port_close (SCHEME_P_ pointer p, int flag) 1938port_close (SCHEME_P_ pointer p, int flag)
1919{ 1939{
1920 port *pt = p->object.port; 1940 port *pt = port (p);
1921 1941
1922 pt->kind &= ~flag; 1942 pt->kind &= ~flag;
1923 1943
1924 if ((pt->kind & (port_input | port_output)) == 0) 1944 if ((pt->kind & (port_input | port_output)) == 0)
1925 { 1945 {
… …
1942 } 1962 }
1943} 1963}
1944#endif 1964#endif
1945 1965
1946/* get new character from input file */ 1966/* get new character from input file */
1947static int 1967ecb_cold static int
1948inchar (SCHEME_P) 1968inchar (SCHEME_P)
1949{ 1969{
1950 int c; 1970 int c;
1951 port *pt; 1971 port *pt = port (SCHEME_V->inport);
1952
1953 pt = SCHEME_V->inport->object.port;
1954 1972
1955 if (pt->kind & port_saw_EOF) 1973 if (pt->kind & port_saw_EOF)
1956 return EOF; 1974 return EOF;
1957 1975
1958 c = basic_inchar (pt); 1976 c = basic_inchar (pt);
… …
1968 } 1986 }
1969 1987
1970 return c; 1988 return c;
1971} 1989}
1972 1990
1973static int ungot = -1; 1991ecb_cold static int
1974
1975static int
1976basic_inchar (port *pt) 1992basic_inchar (port *pt)
1977{ 1993{
1978#if USE_PORTS
1979 if (pt->unget != -1) 1994 if (pt->unget != -1)
1980 { 1995 {
1981 int r = pt->unget; 1996 int r = pt->unget;
1982 pt->unget = -1; 1997 pt->unget = -1;
1983 return r; 1998 return r;
1984 } 1999 }
1985 2000
2001#if USE_PORTS
1986 if (pt->kind & port_file) 2002 if (pt->kind & port_file)
1987 { 2003 {
1988 char c; 2004 char c;
1989 2005
1990 if (!read (pt->rep.stdio.file, &c, 1)) 2006 if (!read (pt->rep.stdio.file, &c, 1))
… …
1998 return EOF; 2014 return EOF;
1999 else 2015 else
2000 return *pt->rep.string.curr++; 2016 return *pt->rep.string.curr++;
2001 } 2017 }
2002#else 2018#else
2003 if (ungot == -1)
2004 {
2005 char c; 2019 char c;
2006 if (!read (0, &c, 1)) 2020
2021 if (!read (pt->rep.stdio.file, &c, 1))
2007 return EOF; 2022 return EOF;
2008 2023
2009 ungot = c;
2010 }
2011
2012 {
2013 int r = ungot;
2014 ungot = -1;
2015 return r; 2024 return c;
2016 }
2017#endif 2025#endif
2018} 2026}
2019 2027
2020/* back character to input buffer */ 2028/* back character to input buffer */
2021static void 2029ecb_cold static void
2022backchar (SCHEME_P_ int c) 2030backchar (SCHEME_P_ int c)
2023{ 2031{
2024#if USE_PORTS 2032 port *pt = port (SCHEME_V->inport);
2025 port *pt;
2026 2033
2027 if (c == EOF) 2034 if (c == EOF)
2028 return; 2035 return;
2029 2036
2030 pt = SCHEME_V->inport->object.port;
2031 pt->unget = c; 2037 pt->unget = c;
2032#else
2033 if (c == EOF)
2034 return;
2035
2036 ungot = c;
2037#endif
2038} 2038}
2039 2039
2040#if USE_PORTS 2040#if USE_PORTS
2041static int 2041ecb_cold static int
2042realloc_port_string (SCHEME_P_ port *p) 2042realloc_port_string (SCHEME_P_ port *p)
2043{ 2043{
2044 char *start = p->rep.string.start; 2044 char *start = p->rep.string.start;
2045 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2045 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2046 char *str = malloc (new_size); 2046 char *str = malloc (new_size);
… …
2059 else 2059 else
2060 return 0; 2060 return 0;
2061} 2061}
2062#endif 2062#endif
2063 2063
2064INTERFACE void 2064ecb_cold static void
2065putstr (SCHEME_P_ const char *s) 2065putchars (SCHEME_P_ const char *s, int len)
2066{ 2066{
2067 port *pt = port (SCHEME_V->outport);
2068
2067#if USE_PORTS 2069#if USE_PORTS
2068 port *pt = SCHEME_V->outport->object.port;
2069
2070 if (pt->kind & port_file)
2071 write (pt->rep.stdio.file, s, strlen (s));
2072 else
2073 for (; *s; s++)
2074 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2075 *pt->rep.string.curr++ = *s;
2076 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2077 *pt->rep.string.curr++ = *s;
2078
2079#else
2080 xwrstr (s);
2081#endif
2082}
2083
2084static void
2085putchars (SCHEME_P_ const char *s, int len)
2086{
2087#if USE_PORTS
2088 port *pt = SCHEME_V->outport->object.port;
2089
2090 if (pt->kind & port_file) 2070 if (pt->kind & port_file)
2091 write (pt->rep.stdio.file, s, len); 2071 write (pt->rep.stdio.file, s, len);
2092 else 2072 else
2093 { 2073 {
2094 for (; len; len--) 2074 for (; len; len--)
… …
2099 *pt->rep.string.curr++ = *s++; 2079 *pt->rep.string.curr++ = *s++;
2100 } 2080 }
2101 } 2081 }
2102 2082
2103#else 2083#else
2104 write (1, s, len); 2084 write (1, s, len); // output not initialised
2105#endif 2085#endif
2086}
2087
2088INTERFACE void
2089putstr (SCHEME_P_ const char *s)
2090{
2091 putchars (SCHEME_A_ s, strlen (s));
2106} 2092}
2107 2093
2108INTERFACE void 2094INTERFACE void
2109putcharacter (SCHEME_P_ int c) 2095putcharacter (SCHEME_P_ int c)
2110{ 2096{
2111#if USE_PORTS
2112 port *pt = SCHEME_V->outport->object.port;
2113
2114 if (pt->kind & port_file)
2115 {
2116 char cc = c;
2117 write (pt->rep.stdio.file, &cc, 1);
2118 }
2119 else
2120 {
2121 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2122 *pt->rep.string.curr++ = c;
2123 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2124 *pt->rep.string.curr++ = c;
2125 }
2126
2127#else
2128 char cc = c; 2097 char cc = c;
2129 write (1, &c, 1); 2098
2130#endif 2099 putchars (SCHEME_A_ &cc, 1);
2131} 2100}
2132 2101
2133/* read characters up to delimiter, but cater to character constants */ 2102/* read characters up to delimiter, but cater to character constants */
2134static char * 2103ecb_cold static char *
2135readstr_upto (SCHEME_P_ int skip, const char *delim) 2104readstr_upto (SCHEME_P_ int skip, const char *delim)
2136{ 2105{
2137 char *p = SCHEME_V->strbuff + skip; 2106 char *p = SCHEME_V->strbuff + skip;
2138 2107
2139 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2108 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
… …
2148 2117
2149 return SCHEME_V->strbuff; 2118 return SCHEME_V->strbuff;
2150} 2119}
2151 2120
2152/* read string expression "xxx...xxx" */ 2121/* read string expression "xxx...xxx" */
2153static pointer 2122ecb_cold static pointer
2154readstrexp (SCHEME_P_ char delim) 2123readstrexp (SCHEME_P_ char delim)
2155{ 2124{
2156 char *p = SCHEME_V->strbuff; 2125 char *p = SCHEME_V->strbuff;
2157 int c; 2126 int c;
2158 int c1 = 0; 2127 int c1 = 0;
… …
2191 case '7': 2160 case '7':
2192 state = st_oct1; 2161 state = st_oct1;
2193 c1 = c - '0'; 2162 c1 = c - '0';
2194 break; 2163 break;
2195 2164
2165 case 'a': *p++ = '\a'; state = st_ok; break;
2166 case 'n': *p++ = '\n'; state = st_ok; break;
2167 case 'r': *p++ = '\r'; state = st_ok; break;
2168 case 't': *p++ = '\t'; state = st_ok; break;
2169
2170 // this overshoots the minimum requirements of r7rs
2171 case ' ':
2172 case '\t':
2173 case '\r':
2174 case '\n':
2175 skipspace (SCHEME_A);
2176 state = st_ok;
2177 break;
2178
2179 //TODO: x should end in ;, not two-digit hex
2196 case 'x': 2180 case 'x':
2197 case 'X': 2181 case 'X':
2198 state = st_x1; 2182 state = st_x1;
2199 c1 = 0; 2183 c1 = 0;
2200 break;
2201
2202 case 'n':
2203 *p++ = '\n';
2204 state = st_ok;
2205 break;
2206
2207 case 't':
2208 *p++ = '\t';
2209 state = st_ok;
2210 break;
2211
2212 case 'r':
2213 *p++ = '\r';
2214 state = st_ok;
2215 break; 2184 break;
2216 2185
2217 default: 2186 default:
2218 *p++ = c; 2187 *p++ = c;
2219 state = st_ok; 2188 state = st_ok;
… …
2271 } 2240 }
2272 } 2241 }
2273} 2242}
2274 2243
2275/* check c is in chars */ 2244/* check c is in chars */
2276ecb_inline int 2245ecb_cold int
2277is_one_of (const char *s, int c) 2246is_one_of (const char *s, int c)
2278{ 2247{
2279 return c == EOF || !!strchr (s, c); 2248 return c == EOF || !!strchr (s, c);
2280} 2249}
2281 2250
2282/* skip white characters */ 2251/* skip white characters */
2283ecb_inline int 2252ecb_cold int
2284skipspace (SCHEME_P) 2253skipspace (SCHEME_P)
2285{ 2254{
2286 int c, curr_line = 0; 2255 int c, curr_line = 0;
2287 2256
2288 do 2257 do
… …
2308 backchar (SCHEME_A_ c); 2277 backchar (SCHEME_A_ c);
2309 return 1; 2278 return 1;
2310} 2279}
2311 2280
2312/* get token */ 2281/* get token */
2313static int 2282ecb_cold static int
2314token (SCHEME_P) 2283token (SCHEME_P)
2315{ 2284{
2316 int c = skipspace (SCHEME_A); 2285 int c = skipspace (SCHEME_A);
2317 2286
2318 if (c == EOF) 2287 if (c == EOF)
… …
2416} 2385}
2417 2386
2418/* ========== Routines for Printing ========== */ 2387/* ========== Routines for Printing ========== */
2419#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2388#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2420 2389
2421static void 2390ecb_cold static void
2422printslashstring (SCHEME_P_ char *p, int len) 2391printslashstring (SCHEME_P_ char *p, int len)
2423{ 2392{
2424 int i; 2393 int i;
2425 unsigned char *s = (unsigned char *) p; 2394 unsigned char *s = (unsigned char *) p;
2426 2395
… …
2482 2451
2483 putcharacter (SCHEME_A_ '"'); 2452 putcharacter (SCHEME_A_ '"');
2484} 2453}
2485 2454
2486/* print atoms */ 2455/* print atoms */
2487static void 2456ecb_cold static void
2488printatom (SCHEME_P_ pointer l, int f) 2457printatom (SCHEME_P_ pointer l, int f)
2489{ 2458{
2490 char *p; 2459 char *p;
2491 int len; 2460 int len;
2492 2461
2493 atom2str (SCHEME_A_ l, f, &p, &len); 2462 atom2str (SCHEME_A_ l, f, &p, &len);
2494 putchars (SCHEME_A_ p, len); 2463 putchars (SCHEME_A_ p, len);
2495} 2464}
2496 2465
2497/* Uses internal buffer unless string pointer is already available */ 2466/* Uses internal buffer unless string pointer is already available */
2498static void 2467ecb_cold static void
2499atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2468atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2500{ 2469{
2501 char *p; 2470 char *p;
2502 2471
2503 if (l == NIL) 2472 if (l == NIL)
… …
2710 return car (d); 2679 return car (d);
2711 2680
2712 p = cons (car (d), cdr (d)); 2681 p = cons (car (d), cdr (d));
2713 q = p; 2682 q = p;
2714 2683
2715 while (cdr (cdr (p)) != NIL) 2684 while (cddr (p) != NIL)
2716 { 2685 {
2717 d = cons (car (p), cdr (p)); 2686 d = cons (car (p), cdr (p));
2718 2687
2719 if (cdr (cdr (p)) != NIL) 2688 if (cddr (p) != NIL)
2720 p = cdr (d); 2689 p = cdr (d);
2721 } 2690 }
2722 2691
2723 set_cdr (p, car (cdr (p))); 2692 set_cdr (p, cadr (p));
2724 return q; 2693 return q;
2725} 2694}
2726 2695
2727/* reverse list -- produce new list */ 2696/* reverse list -- produce new list */
2728static pointer 2697ecb_hot static pointer
2729reverse (SCHEME_P_ pointer a) 2698reverse (SCHEME_P_ pointer a)
2730{ 2699{
2731 /* a must be checked by gc */ 2700 /* a must be checked by gc */
2732 pointer p = NIL; 2701 pointer p = NIL;
2733 2702
… …
2736 2705
2737 return p; 2706 return p;
2738} 2707}
2739 2708
2740/* reverse list --- in-place */ 2709/* reverse list --- in-place */
2741static pointer 2710ecb_hot static pointer
2742reverse_in_place (SCHEME_P_ pointer term, pointer list) 2711reverse_in_place (SCHEME_P_ pointer term, pointer list)
2743{ 2712{
2744 pointer result = term; 2713 pointer result = term;
2745 pointer p = list; 2714 pointer p = list;
2746 2715
… …
2754 2723
2755 return result; 2724 return result;
2756} 2725}
2757 2726
2758/* append list -- produce new list (in reverse order) */ 2727/* append list -- produce new list (in reverse order) */
2759static pointer 2728ecb_hot static pointer
2760revappend (SCHEME_P_ pointer a, pointer b) 2729revappend (SCHEME_P_ pointer a, pointer b)
2761{ 2730{
2762 pointer result = a; 2731 pointer result = a;
2763 pointer p = b; 2732 pointer p = b;
2764 2733
… …
2773 2742
2774 return S_F; /* signal an error */ 2743 return S_F; /* signal an error */
2775} 2744}
2776 2745
2777/* equivalence of atoms */ 2746/* equivalence of atoms */
2778int 2747ecb_hot int
2779eqv (pointer a, pointer b) 2748eqv (pointer a, pointer b)
2780{ 2749{
2781 if (is_string (a)) 2750 if (is_string (a))
2782 { 2751 {
2783 if (is_string (b)) 2752 if (is_string (b))
… …
2877 } 2846 }
2878 else 2847 else
2879 set_car (env, immutable_cons (slot, car (env))); 2848 set_car (env, immutable_cons (slot, car (env)));
2880} 2849}
2881 2850
2882static pointer 2851ecb_hot static pointer
2883find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2852find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2884{ 2853{
2885 pointer x, y; 2854 pointer x, y;
2886 2855
2887 for (x = env; x != NIL; x = cdr (x)) 2856 for (x = env; x != NIL; x = cdr (x))
… …
2908 return NIL; 2877 return NIL;
2909} 2878}
2910 2879
2911#else /* USE_ALIST_ENV */ 2880#else /* USE_ALIST_ENV */
2912 2881
2913ecb_inline void 2882static void
2914new_frame_in_env (SCHEME_P_ pointer old_env) 2883new_frame_in_env (SCHEME_P_ pointer old_env)
2915{ 2884{
2916 SCHEME_V->envir = immutable_cons (NIL, old_env); 2885 SCHEME_V->envir = immutable_cons (NIL, old_env);
2917 setenvironment (SCHEME_V->envir); 2886 setenvironment (SCHEME_V->envir);
2918} 2887}
2919 2888
2920ecb_inline void 2889static void
2921new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2890new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2922{ 2891{
2923 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2892 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2924} 2893}
2925 2894
2926static pointer 2895ecb_hot static pointer
2927find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2896find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2928{ 2897{
2929 pointer x, y; 2898 pointer x, y;
2930 2899
2931 for (x = env; x != NIL; x = cdr (x)) 2900 for (x = env; x != NIL; x = cdr (x))
… …
2945 return NIL; 2914 return NIL;
2946} 2915}
2947 2916
2948#endif /* USE_ALIST_ENV else */ 2917#endif /* USE_ALIST_ENV else */
2949 2918
2950ecb_inline void 2919static void
2951new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2920new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2952{ 2921{
2953 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 2922 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2954 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2923 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2955} 2924}
2956 2925
2957ecb_inline void 2926static void
2958set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2927set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2959{ 2928{
2960 set_cdr (slot, value); 2929 set_cdr (slot, value);
2961} 2930}
2962 2931
2963ecb_inline pointer 2932static pointer
2964slot_value_in_env (pointer slot) 2933slot_value_in_env (pointer slot)
2965{ 2934{
2966 return cdr (slot); 2935 return cdr (slot);
2967} 2936}
2968 2937
2969/* ========== Evaluation Cycle ========== */ 2938/* ========== Evaluation Cycle ========== */
2970 2939
2971static int 2940ecb_cold static int
2972xError_1 (SCHEME_P_ const char *s, pointer a) 2941xError_1 (SCHEME_P_ const char *s, pointer a)
2973{ 2942{
2974#if USE_ERROR_HOOK
2975 pointer x;
2976 pointer hdl = SCHEME_V->ERROR_HOOK;
2977#endif
2978
2979#if USE_PRINTF 2943#if USE_PRINTF
2980#if SHOW_ERROR_LINE 2944#if SHOW_ERROR_LINE
2981 char sbuf[STRBUFFSIZE]; 2945 char sbuf[STRBUFFSIZE];
2982 2946
2983 /* make sure error is not in REPL */ 2947 /* make sure error is not in REPL */
… …
2998 } 2962 }
2999#endif 2963#endif
3000#endif 2964#endif
3001 2965
3002#if USE_ERROR_HOOK 2966#if USE_ERROR_HOOK
3003 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 2967 pointer x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->ERROR_HOOK, 1);
3004 2968
3005 if (x != NIL) 2969 if (x != NIL)
3006 { 2970 {
3007 pointer code = a 2971 pointer code = a
3008 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL) 2972 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
… …
3052 pointer code; 3016 pointer code;
3053}; 3017};
3054 3018
3055# define STACK_GROWTH 3 3019# define STACK_GROWTH 3
3056 3020
3057static void 3021ecb_hot static void
3058s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3022s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3059{ 3023{
3060 int nframes = (uintptr_t)SCHEME_V->dump; 3024 int nframes = (uintptr_t)SCHEME_V->dump;
3061 struct dump_stack_frame *next_frame; 3025 struct dump_stack_frame *next_frame;
3062 3026
3063 /* enough room for the next frame? */ 3027 /* enough room for the next frame? */
3064 if (nframes >= SCHEME_V->dump_size) 3028 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3065 { 3029 {
3066 SCHEME_V->dump_size += STACK_GROWTH; 3030 SCHEME_V->dump_size += STACK_GROWTH;
3067 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); 3031 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3068 } 3032 }
3069 3033
… …
3075 next_frame->code = code; 3039 next_frame->code = code;
3076 3040
3077 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3041 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3078} 3042}
3079 3043
3080static int 3044static ecb_hot int
3081xs_return (SCHEME_P_ pointer a) 3045xs_return (SCHEME_P_ pointer a)
3082{ 3046{
3083 int nframes = (uintptr_t)SCHEME_V->dump; 3047 int nframes = (uintptr_t)SCHEME_V->dump;
3084 struct dump_stack_frame *frame; 3048 struct dump_stack_frame *frame;
3085 3049
… …
3096 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3060 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3097 3061
3098 return 0; 3062 return 0;
3099} 3063}
3100 3064
3101ecb_inline void 3065ecb_cold void
3102dump_stack_reset (SCHEME_P) 3066dump_stack_reset (SCHEME_P)
3103{ 3067{
3104 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3068 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3105 SCHEME_V->dump = (pointer)+0; 3069 SCHEME_V->dump = (pointer)+0;
3106} 3070}
3107 3071
3108ecb_inline void 3072ecb_cold void
3109dump_stack_initialize (SCHEME_P) 3073dump_stack_initialize (SCHEME_P)
3110{ 3074{
3111 SCHEME_V->dump_size = 0; 3075 SCHEME_V->dump_size = 0;
3112 SCHEME_V->dump_base = 0; 3076 SCHEME_V->dump_base = 0;
3113 dump_stack_reset (SCHEME_A); 3077 dump_stack_reset (SCHEME_A);
3114} 3078}
3115 3079
3116static void 3080ecb_cold static void
3117dump_stack_free (SCHEME_P) 3081dump_stack_free (SCHEME_P)
3118{ 3082{
3119 free (SCHEME_V->dump_base); 3083 free (SCHEME_V->dump_base);
3120 SCHEME_V->dump_base = 0; 3084 SCHEME_V->dump_base = 0;
3121 SCHEME_V->dump = (pointer)0; 3085 SCHEME_V->dump = (pointer)0;
3122 SCHEME_V->dump_size = 0; 3086 SCHEME_V->dump_size = 0;
3123} 3087}
3124 3088
3125static void 3089ecb_cold static void
3126dump_stack_mark (SCHEME_P) 3090dump_stack_mark (SCHEME_P)
3127{ 3091{
3128 int nframes = (uintptr_t)SCHEME_V->dump; 3092 int nframes = (uintptr_t)SCHEME_V->dump;
3129 int i; 3093 int i;
3130 3094
… …
3136 mark (frame->envir); 3100 mark (frame->envir);
3137 mark (frame->code); 3101 mark (frame->code);
3138 } 3102 }
3139} 3103}
3140 3104
3141static pointer 3105ecb_cold static pointer
3142ss_get_cont (SCHEME_P) 3106ss_get_cont (SCHEME_P)
3143{ 3107{
3144 int nframes = (uintptr_t)SCHEME_V->dump; 3108 int nframes = (uintptr_t)SCHEME_V->dump;
3145 int i; 3109 int i;
3146 3110
… …
3158 } 3122 }
3159 3123
3160 return cont; 3124 return cont;
3161} 3125}
3162 3126
3163static void 3127ecb_cold static void
3164ss_set_cont (SCHEME_P_ pointer cont) 3128ss_set_cont (SCHEME_P_ pointer cont)
3165{ 3129{
3166 int i = 0; 3130 int i = 0;
3167 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3131 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3168 3132
… …
3180 SCHEME_V->dump = (pointer)(uintptr_t)i; 3144 SCHEME_V->dump = (pointer)(uintptr_t)i;
3181} 3145}
3182 3146
3183#else 3147#else
3184 3148
3185ecb_inline void 3149ecb_cold void
3186dump_stack_reset (SCHEME_P) 3150dump_stack_reset (SCHEME_P)
3187{ 3151{
3188 SCHEME_V->dump = NIL; 3152 SCHEME_V->dump = NIL;
3189} 3153}
3190 3154
3191ecb_inline void 3155ecb_cold void
3192dump_stack_initialize (SCHEME_P) 3156dump_stack_initialize (SCHEME_P)
3193{ 3157{
3194 dump_stack_reset (SCHEME_A); 3158 dump_stack_reset (SCHEME_A);
3195} 3159}
3196 3160
3197static void 3161ecb_cold static void
3198dump_stack_free (SCHEME_P) 3162dump_stack_free (SCHEME_P)
3199{ 3163{
3200 SCHEME_V->dump = NIL; 3164 SCHEME_V->dump = NIL;
3201} 3165}
3202 3166
3203static int 3167ecb_hot static int
3204xs_return (SCHEME_P_ pointer a) 3168xs_return (SCHEME_P_ pointer a)
3205{ 3169{
3206 pointer dump = SCHEME_V->dump; 3170 pointer dump = SCHEME_V->dump;
3207 3171
3208 SCHEME_V->value = a; 3172 SCHEME_V->value = a;
… …
3218 SCHEME_V->dump = dump; 3182 SCHEME_V->dump = dump;
3219 3183
3220 return 0; 3184 return 0;
3221} 3185}
3222 3186
3223static void 3187ecb_hot static void
3224s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3188s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3225{ 3189{
3226 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3190 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3227 cons (args, 3191 cons (args,
3228 cons (SCHEME_V->envir, 3192 cons (SCHEME_V->envir,
3229 cons (code, 3193 cons (code,
3230 SCHEME_V->dump)))); 3194 SCHEME_V->dump))));
3231} 3195}
3232 3196
3233static void 3197ecb_cold static void
3234dump_stack_mark (SCHEME_P) 3198dump_stack_mark (SCHEME_P)
3235{ 3199{
3236 mark (SCHEME_V->dump); 3200 mark (SCHEME_V->dump);
3237} 3201}
3238 3202
3239static pointer 3203ecb_cold static pointer
3240ss_get_cont (SCHEME_P) 3204ss_get_cont (SCHEME_P)
3241{ 3205{
3242 return SCHEME_V->dump; 3206 return SCHEME_V->dump;
3243} 3207}
3244 3208
3245static void 3209ecb_cold static void
3246ss_set_cont (SCHEME_P_ pointer cont) 3210ss_set_cont (SCHEME_P_ pointer cont)
3247{ 3211{
3248 SCHEME_V->dump = cont; 3212 SCHEME_V->dump = cont;
3249} 3213}
3250 3214
3251#endif 3215#endif
3252 3216
3253#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3217#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3254 3218
3255#if EXPERIMENT 3219#if EXPERIMENT
3220
3256static int 3221static int
3257debug (SCHEME_P_ int indent, pointer x) 3222dtree (SCHEME_P_ int indent, pointer x)
3258{ 3223{
3259 int c; 3224 int c;
3260 3225
3261 if (is_syntax (x)) 3226 if (is_syntax (x))
3262 { 3227 {
… …
3280 printf ("%*sS<%s>\n", indent, "", symname (x)); 3245 printf ("%*sS<%s>\n", indent, "", symname (x));
3281 return 24+8; 3246 return 24+8;
3282 3247
3283 case T_CLOSURE: 3248 case T_CLOSURE:
3284 printf ("%*sS<%s>\n", indent, "", "closure"); 3249 printf ("%*sS<%s>\n", indent, "", "closure");
3285 debug (SCHEME_A_ indent + 3, cdr(x)); 3250 dtree (SCHEME_A_ indent + 3, cdr(x));
3286 return 32 + debug (SCHEME_A_ indent + 3, car (x)); 3251 return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3287 3252
3288 case T_PAIR: 3253 case T_PAIR:
3289 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); 3254 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3290 c = debug (SCHEME_A_ indent + 3, car (x)); 3255 c = dtree (SCHEME_A_ indent + 3, car (x));
3291 c += debug (SCHEME_A_ indent + 3, cdr (x)); 3256 c += dtree (SCHEME_A_ indent + 3, cdr (x));
3292 return c + 1; 3257 return c + 1;
3293 3258
3294 case T_PORT: 3259 case T_PORT:
3295 printf ("%*sS<%s>\n", indent, "", "port"); 3260 printf ("%*sS<%s>\n", indent, "", "port");
3296 return 24+8; 3261 return 24+8;
… …
3299 printf ("%*sS<%s>\n", indent, "", "vector"); 3264 printf ("%*sS<%s>\n", indent, "", "vector");
3300 return 24+8; 3265 return 24+8;
3301 3266
3302 case T_ENVIRONMENT: 3267 case T_ENVIRONMENT:
3303 printf ("%*sS<%s>\n", indent, "", "environment"); 3268 printf ("%*sS<%s>\n", indent, "", "environment");
3304 return 0 + debug (SCHEME_A_ indent + 3, car (x)); 3269 return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3305 3270
3306 default: 3271 default:
3307 printf ("unhandled type %d\n", type (x)); 3272 printf ("unhandled type %d\n", type (x));
3308 break; 3273 break;
3309 } 3274 }
3310} 3275}
3311#endif
3312 3276
3277#define DUMP(t) do { printf ("DUMP %s:%d\n", __FILE__, __LINE__); dtree (SCHEME_A_ 0, (t)); } while (0)
3278
3279typedef void *stream[1];
3280
3281#define stream_init() { 0 }
3282#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
3283#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
3284#define stream_free(s) free (s[0])
3285
3286ecb_cold static void
3287stream_put (stream s, uint8_t byte)
3288{
3289 uint32_t *sp = *s;
3290 uint32_t size = sizeof (uint32_t) * 2;
3291 uint32_t offs = size;
3292
3293 if (ecb_expect_true (sp))
3294 {
3295 offs = sp[0];
3296 size = sp[1];
3297 }
3298
3299 if (ecb_expect_false (offs == size))
3300 {
3301 size *= 2;
3302 sp = realloc (sp, size);
3303 *s = sp;
3304 sp[1] = size;
3305
3306 }
3307
3308 ((uint8_t *)sp)[offs++] = byte;
3309 sp[0] = offs;
3310}
3311
3312ecb_cold static void
3313stream_put_v (stream s, uint32_t v)
3314{
3315 while (v > 0x7f)
3316 {
3317 stream_put (s, v | 0x80);
3318 v >>= 7;
3319 }
3320
3321 stream_put (s, v);
3322}
3323
3324ecb_cold static void
3325stream_put_tv (stream s, int bop, uint32_t v)
3326{
3327 printf ("put tv %d %d\n", bop, v);//D
3328 stream_put (s, bop);
3329 stream_put_v (s, v);
3330}
3331
3332ecb_cold static void
3333stream_put_stream (stream s, stream o)
3334{
3335 uint32_t i;
3336
3337 for (i = 0; i < stream_size (o); ++i)
3338 stream_put (s, stream_data (o)[i]);
3339
3340 stream_free (o);
3341}
3342
3343// calculates a (preferably small) integer that makes it possible to find
3344// the symbol again. if pointers were offsets into a memory area... until
3345// then, we return segment number in the low bits, and offset in the high
3346// bits.
3347// also, this function must never return 0.
3348ecb_cold static uint32_t
3349symbol_id (SCHEME_P_ pointer sym)
3350{
3351 struct cell *p = CELL (sym);
3352 int i;
3353
3354 for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3355 if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3356 return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3357
3358 abort ();
3359}
3360
3361ecb_cold static uint32_t
3362cell_id (SCHEME_P_ pointer p)
3363{
3364 return symbol_id (SCHEME_A_ p);
3365}
3366
3367enum byteop
3368{
3369 BOP_NIL,
3370 BOP_SYNTAX,
3371 BOP_INTEGER,
3372 BOP_SYMBOL,
3373 BOP_LIST_BEG,
3374 BOP_LIST_END,
3375 BOP_BIFT, // branch if true
3376 BOP_BIFF, // branch if false
3377 BOP_BIFNE, // branch if not eqv?
3378 BOP_BRA, // "short" branch
3379 BOP_JMP, // "long" jump
3380 BOP_DATUM,
3381 BOP_LET,
3382 BOP_LETAST,
3383 BOP_LETREC,
3384 BOP_DEFINE,
3385 BOP_MACRO,
3386 BOP_SET,
3387 BOP_BEGIN,
3388 BOP_LAMBDA,
3389};
3390
3391ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
3392
3393ecb_cold static void
3394compile_list (SCHEME_P_ stream s, pointer x)
3395{
3396 for (; x != NIL; x = cdr (x))
3397 compile_expr (SCHEME_A_ s, car (x));
3398}
3399
3313static int 3400static void
3401compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
3402{
3403 //TODO: borked
3404 stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
3405
3406 stream_put (s, BOP_BIFF);
3407 compile_expr (SCHEME_A_ s, cond);
3408 stream_put_v (s, stream_size (sift));
3409 stream_put_stream (s, sift);
3410
3411 if (iff != NIL)
3412 {
3413 stream siff = stream_init (); compile_expr (SCHEME_A_ siff, iff);
3414 stream_put_tv (s, BOP_BRA, stream_size (siff));
3415 stream_put_stream (s, siff);
3416 }
3417}
3418
3419typedef uint32_t stream_fixup;
3420
3421static stream_fixup
3422stream_put_fixup (stream s)
3423{
3424 stream_put (s, 0);
3425 stream_put (s, 0);
3426
3427 return stream_size (s);
3428}
3429
3430static void
3431stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target)
3432{
3433 target -= fixup;
3434 assert (target < (1 << 14));
3435 stream_data (s)[fixup - 2] = target | 0x80;
3436 stream_data (s)[fixup - 1] = target >> 7;
3437}
3438
3439static void
3440compile_and_or (SCHEME_P_ stream s, int and, pointer x)
3441{
3442 if (cdr (x) == NIL)
3443 compile_expr (SCHEME_A_ s, car (x));
3444 else
3445 {
3446 stream_put (s, and ? BOP_BIFF : BOP_BIFT);
3447 compile_expr (SCHEME_A_ s, car (x));
3448 stream_fixup end = stream_put_fixup (s);
3449
3450 compile_and_or (SCHEME_A_ s, and, cdr (x));
3451 stream_fix_fixup (s, end, stream_size (s));
3452 }
3453}
3454
3455ecb_cold static void
3456compile_expr (SCHEME_P_ stream s, pointer x)
3457{
3458 if (x == NIL)
3459 {
3460 stream_put (s, BOP_NIL);
3461 return;
3462 }
3463
3464 if (is_pair (x))
3465 {
3466 pointer head = car (x);
3467
3468 if (is_syntax (head))
3469 {
3470 x = cdr (x);
3471
3472 switch (syntaxnum (head))
3473 {
3474 case OP_IF0: /* if */
3475 compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
3476 break;
3477
3478 case OP_OR0: /* or */
3479 compile_and_or (SCHEME_A_ s, 0, x);
3480 break;
3481
3482 case OP_AND0: /* and */
3483 compile_and_or (SCHEME_A_ s, 1, x);
3484 break;
3485
3486 case OP_CASE0: /* case */
3487 abort ();
3488 break;
3489
3490 case OP_COND0: /* cond */
3491 abort ();
3492 break;
3493
3494 case OP_LET0: /* let */
3495 case OP_LET0AST: /* let* */
3496 case OP_LET0REC: /* letrec */
3497 switch (syntaxnum (head))
3498 {
3499 case OP_LET0: stream_put (s, BOP_LET ); break;
3500 case OP_LET0AST: stream_put (s, BOP_LETAST); break;
3501 case OP_LET0REC: stream_put (s, BOP_LETREC); break;
3502 }
3503
3504 {
3505 pointer bindings = car (x);
3506 pointer body = cadr (x);
3507
3508 for (x = bindings; x != NIL; x = cdr (x))
3509 {
3510 pointer init = NIL;
3511 pointer var = car (x);
3512
3513 if (is_pair (var))
3514 {
3515 init = cdr (var);
3516 var = car (var);
3517 }
3518
3519 stream_put_v (s, symbol_id (SCHEME_A_ var));
3520 compile_expr (SCHEME_A_ s, init);
3521 }
3522
3523 stream_put_v (s, 0);
3524 compile_expr (SCHEME_A_ s, body);
3525 }
3526 break;
3527
3528 case OP_DEF0: /* define */
3529 case OP_MACRO0: /* macro */
3530 stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO);
3531 stream_put_v (s, cell_id (SCHEME_A_ car (x)));
3532 compile_expr (SCHEME_A_ s, cadr (x));
3533 break;
3534
3535 case OP_SET0: /* set! */
3536 stream_put (s, BOP_SET);
3537 stream_put_v (s, symbol_id (SCHEME_A_ car (x)));
3538 compile_expr (SCHEME_A_ s, cadr (x));
3539 break;
3540
3541 case OP_BEGIN: /* begin */
3542 stream_put (s, BOP_BEGIN);
3543 compile_list (SCHEME_A_ s, x);
3544 return;
3545
3546 case OP_DELAY: /* delay */
3547 abort ();
3548 break;
3549
3550 case OP_QUOTE: /* quote */
3551 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3552 break;
3553
3554 case OP_LAMBDA: /* lambda */
3555 {
3556 pointer formals = car (x);
3557 pointer body = cadr (x);
3558
3559 stream_put (s, BOP_LAMBDA);
3560
3561 for (; is_pair (formals); formals = cdr (formals))
3562 stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
3563
3564 stream_put_v (s, 0);
3565 stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals));
3566
3567 compile_expr (SCHEME_A_ s, body);
3568 }
3569 break;
3570
3571 case OP_C0STREAM:/* cons-stream */
3572 abort ();
3573 break;
3574 }
3575
3576 return;
3577 }
3578
3579 pointer m = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, head, 1);
3580
3581 if (m != NIL)
3582 {
3583 m = slot_value_in_env (m);
3584
3585 if (is_macro (m))
3586 {
3587 s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
3588 SCHEME_V->code = m;
3589 SCHEME_V->args = cons (x, NIL);
3590 Eval_Cycle (SCHEME_A_ OP_APPLY);
3591 x = SCHEME_V->value;
3592 compile_expr (SCHEME_A_ s, SCHEME_V->value);
3593 return;
3594 }
3595 }
3596 }
3597
3598 switch (type (x))
3599 {
3600 case T_INTEGER:
3601 {
3602 IVALUE iv = ivalue_unchecked (x);
3603 iv = iv < 0 ? ((uint32_t)-iv << 1) | 1 : (uint32_t)iv << 1;
3604 stream_put_tv (s, BOP_INTEGER, iv);
3605 }
3606 return;
3607
3608 case T_SYMBOL:
3609 stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3610 return;
3611
3612 case T_PAIR:
3613 stream_put (s, BOP_LIST_BEG);
3614
3615 for (; x != NIL; x = cdr (x))
3616 compile_expr (SCHEME_A_ s, car (x));
3617
3618 stream_put (s, BOP_LIST_END);
3619 return;
3620
3621 default:
3622 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3623 break;
3624 }
3625}
3626
3627ecb_cold static int
3628compile_closure (SCHEME_P_ pointer p)
3629{
3630 stream s = stream_init ();
3631
3632 compile_list (SCHEME_A_ s, cdar (p));
3633
3634 FILE *xxd = popen ("xxd", "we");
3635 fwrite (stream_data (s), 1, stream_size (s), xxd);
3636 fclose (xxd);
3637
3638 return stream_size (s);
3639}
3640
3641#endif
3642
3643/* syntax, eval, core, ... */
3644ecb_hot static int
3314opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3645opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3315{ 3646{
3316 pointer args = SCHEME_V->args; 3647 pointer args = SCHEME_V->args;
3317 pointer x, y; 3648 pointer x, y;
3318 3649
3319 switch (op) 3650 switch (op)
3320 { 3651 {
3321#if EXPERIMENT //D 3652#if EXPERIMENT //D
3322 case OP_DEBUG: 3653 case OP_DEBUG:
3323 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3654 {
3655 uint32_t len = compile_closure (SCHEME_A_ car (args));
3656 printf ("len = %d\n", len);
3324 printf ("\n"); 3657 printf ("\n");
3325 s_return (S_T); 3658 s_return (S_T);
3659 }
3660
3661 case OP_DEBUG2:
3662 return -1;
3326#endif 3663#endif
3664
3327 case OP_LOAD: /* load */ 3665 case OP_LOAD: /* load */
3328 if (file_interactive (SCHEME_A)) 3666 if (file_interactive (SCHEME_A))
3329 { 3667 {
3330 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3668 putstr (SCHEME_A_ "Loading ");
3331 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3669 putstr (SCHEME_A_ strvalue (car (args)));
3670 putcharacter (SCHEME_A_ '\n');
3332 } 3671 }
3333 3672
3334 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3673 if (!file_push (SCHEME_A_ strvalue (car (args))))
3335 Error_1 ("unable to open", car (args)); 3674 Error_1 ("unable to open", car (args));
3336 else 3675
3337 {
3338 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3676 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3339 s_goto (OP_T0LVL); 3677 s_goto (OP_T0LVL);
3340 }
3341 3678
3342 case OP_T0LVL: /* top level */ 3679 case OP_T0LVL: /* top level */
3343 3680
3344 /* If we reached the end of file, this loop is done. */ 3681 /* If we reached the end of file, this loop is done. */
3345 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3682 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3346 { 3683 {
3347 if (SCHEME_V->file_i == 0) 3684 if (SCHEME_V->file_i == 0)
3348 { 3685 {
3349 SCHEME_V->args = NIL; 3686 SCHEME_V->args = NIL;
3350 s_goto (OP_QUIT); 3687 s_goto (OP_QUIT);
… …
3361 /* If interactive, be nice to user. */ 3698 /* If interactive, be nice to user. */
3362 if (file_interactive (SCHEME_A)) 3699 if (file_interactive (SCHEME_A))
3363 { 3700 {
3364 SCHEME_V->envir = SCHEME_V->global_env; 3701 SCHEME_V->envir = SCHEME_V->global_env;
3365 dump_stack_reset (SCHEME_A); 3702 dump_stack_reset (SCHEME_A);
3366 putstr (SCHEME_A_ "\n"); 3703 putcharacter (SCHEME_A_ '\n');
3704#if EXPERIMENT
3705 system ("ps v $PPID");
3706#endif
3367 putstr (SCHEME_A_ prompt); 3707 putstr (SCHEME_A_ prompt);
3368 } 3708 }
3369 3709
3370 /* Set up another iteration of REPL */ 3710 /* Set up another iteration of REPL */
3371 SCHEME_V->nesting = 0; 3711 SCHEME_V->nesting = 0;
… …
3406 { 3746 {
3407 SCHEME_V->print_flag = 1; 3747 SCHEME_V->print_flag = 1;
3408 SCHEME_V->args = SCHEME_V->value; 3748 SCHEME_V->args = SCHEME_V->value;
3409 s_goto (OP_P0LIST); 3749 s_goto (OP_P0LIST);
3410 } 3750 }
3411 else 3751
3412 s_return (SCHEME_V->value); 3752 s_return (SCHEME_V->value);
3413 3753
3414 case OP_EVAL: /* main part of evaluation */ 3754 case OP_EVAL: /* main part of evaluation */
3415#if USE_TRACING 3755#if USE_TRACING
3416 if (SCHEME_V->tracing) 3756 if (SCHEME_V->tracing)
3417 { 3757 {
… …
3428#endif 3768#endif
3429 if (is_symbol (SCHEME_V->code)) /* symbol */ 3769 if (is_symbol (SCHEME_V->code)) /* symbol */
3430 { 3770 {
3431 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3771 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3432 3772
3433 if (x != NIL) 3773 if (x == NIL)
3434 s_return (slot_value_in_env (x));
3435 else
3436 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3774 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3775
3776 s_return (slot_value_in_env (x));
3437 } 3777 }
3438 else if (is_pair (SCHEME_V->code)) 3778 else if (is_pair (SCHEME_V->code))
3439 { 3779 {
3440 x = car (SCHEME_V->code); 3780 x = car (SCHEME_V->code);
3441 3781
… …
3450 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3790 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3451 SCHEME_V->code = x; 3791 SCHEME_V->code = x;
3452 s_goto (OP_EVAL); 3792 s_goto (OP_EVAL);
3453 } 3793 }
3454 } 3794 }
3455 else 3795
3456 s_return (SCHEME_V->code); 3796 s_return (SCHEME_V->code);
3457 3797
3458 case OP_E0ARGS: /* eval arguments */ 3798 case OP_E0ARGS: /* eval arguments */
3459 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ 3799 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3460 { 3800 {
3461 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3801 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3462 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3802 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3463 SCHEME_V->code = SCHEME_V->value; 3803 SCHEME_V->code = SCHEME_V->value;
3464 s_goto (OP_APPLY); 3804 s_goto (OP_APPLY);
3465 } 3805 }
3466 else 3806
3467 {
3468 SCHEME_V->code = cdr (SCHEME_V->code); 3807 SCHEME_V->code = cdr (SCHEME_V->code);
3469 s_goto (OP_E1ARGS); 3808 s_goto (OP_E1ARGS);
3470 }
3471 3809
3472 case OP_E1ARGS: /* eval arguments */ 3810 case OP_E1ARGS: /* eval arguments */
3473 args = cons (SCHEME_V->value, args); 3811 args = cons (SCHEME_V->value, args);
3474 3812
3475 if (is_pair (SCHEME_V->code)) /* continue */ 3813 if (is_pair (SCHEME_V->code)) /* continue */
… …
3486 SCHEME_V->args = cdr (args); 3824 SCHEME_V->args = cdr (args);
3487 s_goto (OP_APPLY); 3825 s_goto (OP_APPLY);
3488 } 3826 }
3489 3827
3490#if USE_TRACING 3828#if USE_TRACING
3491
3492 case OP_TRACING: 3829 case OP_TRACING:
3493 { 3830 {
3494 int tr = SCHEME_V->tracing; 3831 int tr = SCHEME_V->tracing;
3495 3832
3496 SCHEME_V->tracing = ivalue_unchecked (car (args)); 3833 SCHEME_V->tracing = ivalue_unchecked (car (args));
3497 s_return (mk_integer (SCHEME_A_ tr)); 3834 s_return (mk_integer (SCHEME_A_ tr));
3498 } 3835 }
3499
3500#endif 3836#endif
3501 3837
3502 case OP_APPLY: /* apply 'code' to 'args' */ 3838 case OP_APPLY: /* apply 'code' to 'args' */
3503#if USE_TRACING 3839#if USE_TRACING
3504 if (SCHEME_V->tracing) 3840 if (SCHEME_V->tracing)
… …
3518 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3854 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3519 else if (is_foreign (SCHEME_V->code)) 3855 else if (is_foreign (SCHEME_V->code))
3520 { 3856 {
3521 /* Keep nested calls from GC'ing the arglist */ 3857 /* Keep nested calls from GC'ing the arglist */
3522 push_recent_alloc (SCHEME_A_ args, NIL); 3858 push_recent_alloc (SCHEME_A_ args, NIL);
3523 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3859 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3524 3860
3525 s_return (x); 3861 s_return (x);
3526 } 3862 }
3527 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3863 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3528 { 3864 {
… …
3558 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3894 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3559 { 3895 {
3560 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3896 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3561 s_return (args != NIL ? car (args) : NIL); 3897 s_return (args != NIL ? car (args) : NIL);
3562 } 3898 }
3563 else 3899
3564 Error_0 ("illegal function"); 3900 Error_0 ("illegal function");
3565 3901
3566 case OP_DOMACRO: /* do macro */ 3902 case OP_DOMACRO: /* do macro */
3567 SCHEME_V->code = SCHEME_V->value; 3903 SCHEME_V->code = SCHEME_V->value;
3568 s_goto (OP_EVAL); 3904 s_goto (OP_EVAL);
3569
3570#if 1
3571 3905
3572 case OP_LAMBDA: /* lambda */ 3906 case OP_LAMBDA: /* lambda */
3573 /* If the hook is defined, apply it to SCHEME_V->code, otherwise 3907 /* If the hook is defined, apply it to SCHEME_V->code, otherwise
3574 set SCHEME_V->value fall thru */ 3908 set SCHEME_V->value fall thru */
3575 { 3909 {
… …
3582 SCHEME_V->code = slot_value_in_env (f); 3916 SCHEME_V->code = slot_value_in_env (f);
3583 s_goto (OP_APPLY); 3917 s_goto (OP_APPLY);
3584 } 3918 }
3585 3919
3586 SCHEME_V->value = SCHEME_V->code; 3920 SCHEME_V->value = SCHEME_V->code;
3587 /* Fallthru */
3588 } 3921 }
3922 /* Fallthru */
3589 3923
3590 case OP_LAMBDA1: 3924 case OP_LAMBDA1:
3591 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir)); 3925 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));
3592
3593#else
3594
3595 case OP_LAMBDA: /* lambda */
3596 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3597
3598#endif
3599 3926
3600 case OP_MKCLOSURE: /* make-closure */ 3927 case OP_MKCLOSURE: /* make-closure */
3601 x = car (args); 3928 x = car (args);
3602 3929
3603 if (car (x) == SCHEME_V->LAMBDA) 3930 if (car (x) == SCHEME_V->LAMBDA)
… …
3642 else 3969 else
3643 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 3970 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3644 3971
3645 s_return (SCHEME_V->code); 3972 s_return (SCHEME_V->code);
3646 3973
3647
3648 case OP_DEFP: /* defined? */ 3974 case OP_DEFP: /* defined? */
3649 x = SCHEME_V->envir; 3975 x = SCHEME_V->envir;
3650 3976
3651 if (cdr (args) != NIL) 3977 if (cdr (args) != NIL)
3652 x = cadr (args); 3978 x = cadr (args);
… …
3670 s_return (SCHEME_V->value); 3996 s_return (SCHEME_V->value);
3671 } 3997 }
3672 else 3998 else
3673 Error_1 ("set!: unbound variable:", SCHEME_V->code); 3999 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3674 4000
3675
3676 case OP_BEGIN: /* begin */ 4001 case OP_BEGIN: /* begin */
3677 if (!is_pair (SCHEME_V->code)) 4002 if (!is_pair (SCHEME_V->code))
3678 s_return (SCHEME_V->code); 4003 s_return (SCHEME_V->code);
3679 4004
3680 if (cdr (SCHEME_V->code) != NIL) 4005 if (cdr (SCHEME_V->code) != NIL)
… …
3691 case OP_IF1: /* if */ 4016 case OP_IF1: /* if */
3692 if (is_true (SCHEME_V->value)) 4017 if (is_true (SCHEME_V->value))
3693 SCHEME_V->code = car (SCHEME_V->code); 4018 SCHEME_V->code = car (SCHEME_V->code);
3694 else 4019 else
3695 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ 4020 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
4021
3696 s_goto (OP_EVAL); 4022 s_goto (OP_EVAL);
3697 4023
3698 case OP_LET0: /* let */ 4024 case OP_LET0: /* let */
3699 SCHEME_V->args = NIL; 4025 SCHEME_V->args = NIL;
3700 SCHEME_V->value = SCHEME_V->code; 4026 SCHEME_V->value = SCHEME_V->code;
3701 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); 4027 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3702 s_goto (OP_LET1); 4028 s_goto (OP_LET1);
3703 4029
3704 case OP_LET1: /* let (calculate parameters) */ 4030 case OP_LET1: /* let (calculate parameters) */
4031 case OP_LET1REC: /* letrec (calculate parameters) */
3705 args = cons (SCHEME_V->value, args); 4032 args = cons (SCHEME_V->value, args);
3706 4033
3707 if (is_pair (SCHEME_V->code)) /* continue */ 4034 if (is_pair (SCHEME_V->code)) /* continue */
3708 { 4035 {
3709 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 4036 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3710 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); 4037 Error_1 ("Bad syntax of binding spec in let/letrec:", car (SCHEME_V->code));
3711 4038
3712 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); 4039 s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code));
3713 SCHEME_V->code = cadar (SCHEME_V->code); 4040 SCHEME_V->code = cadar (SCHEME_V->code);
3714 SCHEME_V->args = NIL; 4041 SCHEME_V->args = NIL;
3715 s_goto (OP_EVAL); 4042 s_goto (OP_EVAL);
3716 } 4043 }
3717 else /* end */ 4044
3718 { 4045 /* end */
3719 args = reverse_in_place (SCHEME_A_ NIL, args); 4046 args = reverse_in_place (SCHEME_A_ NIL, args);
3720 SCHEME_V->code = car (args); 4047 SCHEME_V->code = car (args);
3721 SCHEME_V->args = cdr (args); 4048 SCHEME_V->args = cdr (args);
3722 s_goto (OP_LET2); 4049 s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC);
3723 }
3724 4050
3725 case OP_LET2: /* let */ 4051 case OP_LET2: /* let */
3726 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4052 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3727 4053
3728 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 4054 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
… …
3732 if (is_symbol (car (SCHEME_V->code))) /* named let */ 4058 if (is_symbol (car (SCHEME_V->code))) /* named let */
3733 { 4059 {
3734 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 4060 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3735 { 4061 {
3736 if (!is_pair (x)) 4062 if (!is_pair (x))
3737 Error_1 ("Bad syntax of binding in let :", x); 4063 Error_1 ("Bad syntax of binding in let:", x);
3738 4064
3739 if (!is_list (SCHEME_A_ car (x))) 4065 if (!is_list (SCHEME_A_ car (x)))
3740 Error_1 ("Bad syntax of binding in let :", car (x)); 4066 Error_1 ("Bad syntax of binding in let:", car (x));
3741 4067
3742 args = cons (caar (x), args); 4068 args = cons (caar (x), args);
3743 } 4069 }
3744 4070
3745 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)), 4071 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
… …
3762 SCHEME_V->code = cdr (SCHEME_V->code); 4088 SCHEME_V->code = cdr (SCHEME_V->code);
3763 s_goto (OP_BEGIN); 4089 s_goto (OP_BEGIN);
3764 } 4090 }
3765 4091
3766 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code))) 4092 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code)))
3767 Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code)); 4093 Error_1 ("Bad syntax of binding spec in let*:", car (SCHEME_V->code));
3768 4094
3769 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code)); 4095 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
3770 SCHEME_V->code = car (cdaar (SCHEME_V->code)); 4096 SCHEME_V->code = car (cdaar (SCHEME_V->code));
3771 s_goto (OP_EVAL); 4097 s_goto (OP_EVAL);
3772 4098
… …
3783 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code); 4109 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3784 SCHEME_V->code = cadar (SCHEME_V->code); 4110 SCHEME_V->code = cadar (SCHEME_V->code);
3785 SCHEME_V->args = NIL; 4111 SCHEME_V->args = NIL;
3786 s_goto (OP_EVAL); 4112 s_goto (OP_EVAL);
3787 } 4113 }
3788 else /* end */ 4114
4115 /* end */
3789 { 4116
3790 SCHEME_V->code = args; 4117 SCHEME_V->code = args;
3791 SCHEME_V->args = NIL; 4118 SCHEME_V->args = NIL;
3792 s_goto (OP_BEGIN); 4119 s_goto (OP_BEGIN);
3793 }
3794 4120
3795 case OP_LET0REC: /* letrec */ 4121 case OP_LET0REC: /* letrec */
3796 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4122 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3797 SCHEME_V->args = NIL; 4123 SCHEME_V->args = NIL;
3798 SCHEME_V->value = SCHEME_V->code; 4124 SCHEME_V->value = SCHEME_V->code;
3799 SCHEME_V->code = car (SCHEME_V->code); 4125 SCHEME_V->code = car (SCHEME_V->code);
3800 s_goto (OP_LET1REC); 4126 s_goto (OP_LET1REC);
3801 4127
3802 case OP_LET1REC: /* letrec (calculate parameters) */ 4128 /* OP_LET1REC handled by OP_LET1 */
3803 args = cons (SCHEME_V->value, args);
3804
3805 if (is_pair (SCHEME_V->code)) /* continue */
3806 {
3807 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3808 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3809
3810 s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3811 SCHEME_V->code = cadar (SCHEME_V->code);
3812 SCHEME_V->args = NIL;
3813 s_goto (OP_EVAL);
3814 }
3815 else /* end */
3816 {
3817 args = reverse_in_place (SCHEME_A_ NIL, args);
3818 SCHEME_V->code = car (args);
3819 SCHEME_V->args = cdr (args);
3820 s_goto (OP_LET2REC);
3821 }
3822 4129
3823 case OP_LET2REC: /* letrec */ 4130 case OP_LET2REC: /* letrec */
3824 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) 4131 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3825 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 4132 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3826 4133
… …
3856 } 4163 }
3857 else 4164 else
3858 { 4165 {
3859 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) 4166 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3860 s_return (NIL); 4167 s_return (NIL);
3861 else 4168
3862 {
3863 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 4169 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3864 SCHEME_V->code = caar (SCHEME_V->code); 4170 SCHEME_V->code = caar (SCHEME_V->code);
3865 s_goto (OP_EVAL); 4171 s_goto (OP_EVAL);
3866 }
3867 } 4172 }
3868 4173
3869 case OP_DELAY: /* delay */ 4174 case OP_DELAY: /* delay */
3870 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 4175 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3871 set_typeflag (x, T_PROMISE); 4176 set_typeflag (x, T_PROMISE);
… …
3882 case OP_AND1: /* and */ 4187 case OP_AND1: /* and */
3883 if (is_false (SCHEME_V->value)) 4188 if (is_false (SCHEME_V->value))
3884 s_return (SCHEME_V->value); 4189 s_return (SCHEME_V->value);
3885 else if (SCHEME_V->code == NIL) 4190 else if (SCHEME_V->code == NIL)
3886 s_return (SCHEME_V->value); 4191 s_return (SCHEME_V->value);
3887 else 4192
3888 {
3889 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 4193 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3890 SCHEME_V->code = car (SCHEME_V->code); 4194 SCHEME_V->code = car (SCHEME_V->code);
3891 s_goto (OP_EVAL); 4195 s_goto (OP_EVAL);
3892 }
3893 4196
3894 case OP_OR0: /* or */ 4197 case OP_OR0: /* or */
3895 if (SCHEME_V->code == NIL) 4198 if (SCHEME_V->code == NIL)
3896 s_return (S_F); 4199 s_return (S_F);
3897 4200
… …
3902 case OP_OR1: /* or */ 4205 case OP_OR1: /* or */
3903 if (is_true (SCHEME_V->value)) 4206 if (is_true (SCHEME_V->value))
3904 s_return (SCHEME_V->value); 4207 s_return (SCHEME_V->value);
3905 else if (SCHEME_V->code == NIL) 4208 else if (SCHEME_V->code == NIL)
3906 s_return (SCHEME_V->value); 4209 s_return (SCHEME_V->value);
3907 else 4210
3908 {
3909 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 4211 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3910 SCHEME_V->code = car (SCHEME_V->code); 4212 SCHEME_V->code = car (SCHEME_V->code);
3911 s_goto (OP_EVAL); 4213 s_goto (OP_EVAL);
3912 }
3913 4214
3914 case OP_C0STREAM: /* cons-stream */ 4215 case OP_C0STREAM: /* cons-stream */
3915 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 4216 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3916 SCHEME_V->code = car (SCHEME_V->code); 4217 SCHEME_V->code = car (SCHEME_V->code);
3917 s_goto (OP_EVAL); 4218 s_goto (OP_EVAL);
… …
3982 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x)); 4283 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3983 SCHEME_V->code = caar (x); 4284 SCHEME_V->code = caar (x);
3984 s_goto (OP_EVAL); 4285 s_goto (OP_EVAL);
3985 } 4286 }
3986 } 4287 }
3987 else 4288
3988 s_return (NIL); 4289 s_return (NIL);
3989 4290
3990 case OP_CASE2: /* case */ 4291 case OP_CASE2: /* case */
3991 if (is_true (SCHEME_V->value)) 4292 if (is_true (SCHEME_V->value))
3992 s_goto (OP_BEGIN); 4293 s_goto (OP_BEGIN);
3993 else 4294
3994 s_return (NIL); 4295 s_return (NIL);
3995 4296
3996 case OP_PAPPLY: /* apply */ 4297 case OP_PAPPLY: /* apply */
3997 SCHEME_V->code = car (args); 4298 SCHEME_V->code = car (args);
3998 SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); 4299 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3999 /*SCHEME_V->args = cadr(args); */ 4300 /*SCHEME_V->args = cadr(args); */
… …
4013 } 4314 }
4014 4315
4015 if (USE_ERROR_CHECKING) abort (); 4316 if (USE_ERROR_CHECKING) abort ();
4016} 4317}
4017 4318
4018static int 4319/* math, cxr */
4320ecb_hot static int
4019opexe_1 (SCHEME_P_ enum scheme_opcodes op) 4321opexe_1 (SCHEME_P_ enum scheme_opcodes op)
4020{ 4322{
4021 pointer args = SCHEME_V->args; 4323 pointer args = SCHEME_V->args;
4022 pointer x = car (args); 4324 pointer x = car (args);
4023 num v; 4325 num v;
4024 4326
4025 switch (op) 4327 switch (op)
4026 { 4328 {
4027#if USE_MATH 4329#if USE_MATH
4028 case OP_INEX2EX: /* inexact->exact */ 4330 case OP_INEX2EX: /* inexact->exact */
4029 {
4030 if (is_integer (x)) 4331 if (!is_integer (x))
4031 s_return (x); 4332 {
4032
4033 RVALUE r = rvalue_unchecked (x); 4333 RVALUE r = rvalue_unchecked (x);
4034 4334
4035 if (r == (RVALUE)(IVALUE)r) 4335 if (r == (RVALUE)(IVALUE)r)
4036 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4336 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4037 else 4337 else
4038 Error_1 ("inexact->exact: not integral:", x); 4338 Error_1 ("inexact->exact: not integral:", x);
4039 } 4339 }
4040 4340
4341 s_return (x);
4342
4343 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4344 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4345 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4346 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4347
4348 case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4041 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4349 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4042 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4350 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4351 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4043 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4352 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4044 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4353 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4045 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4354 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4046 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4355 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4047 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4356 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4048 4357
4049 case OP_ATAN: 4358 case OP_ATAN:
4359 s_return (mk_real (SCHEME_A_
4050 if (cdr (args) == NIL) 4360 cdr (args) == NIL
4051 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4361 ? atan (rvalue (x))
4052 else 4362 : atan2 (rvalue (x), rvalue (cadr (args)))));
4053 {
4054 pointer y = cadr (args);
4055 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4056 }
4057
4058 case OP_SQRT:
4059 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4060 4363
4061 case OP_EXPT: 4364 case OP_EXPT:
4062 { 4365 {
4063 RVALUE result; 4366 RVALUE result;
4064 int real_result = 1; 4367 int real_result = 1;
… …
4087 if (real_result) 4390 if (real_result)
4088 s_return (mk_real (SCHEME_A_ result)); 4391 s_return (mk_real (SCHEME_A_ result));
4089 else 4392 else
4090 s_return (mk_integer (SCHEME_A_ result)); 4393 s_return (mk_integer (SCHEME_A_ result));
4091 } 4394 }
4092
4093 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4094 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4095
4096 case OP_TRUNCATE:
4097 {
4098 RVALUE n = rvalue (x);
4099 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4100 }
4101
4102 case OP_ROUND:
4103 if (is_integer (x))
4104 s_return (x);
4105
4106 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4107#endif 4395#endif
4108 4396
4109 case OP_ADD: /* + */ 4397 case OP_ADD: /* + */
4110 v = num_zero; 4398 v = num_zero;
4111 4399
… …
4413 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4701 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4414 4702
4415 s_return (newstr); 4703 s_return (newstr);
4416 } 4704 }
4417 4705
4418 case OP_SUBSTR: /* substring */ 4706 case OP_STRING_COPY: /* substring/string-copy */
4419 { 4707 {
4420 char *str = strvalue (x); 4708 char *str = strvalue (x);
4421 int index0 = ivalue_unchecked (cadr (args)); 4709 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4422 int index1; 4710 int index1;
4423 int len; 4711 int len;
4424 4712
4425 if (index0 > strlength (x)) 4713 if (index0 > strlength (x))
4426 Error_1 ("substring: start out of bounds:", cadr (args)); 4714 Error_1 ("string->copy: start out of bounds:", cadr (args));
4427 4715
4428 if (cddr (args) != NIL) 4716 if (cddr (args) != NIL)
4429 { 4717 {
4430 index1 = ivalue_unchecked (caddr (args)); 4718 index1 = ivalue_unchecked (caddr (args));
4431 4719
4432 if (index1 > strlength (x) || index1 < index0) 4720 if (index1 > strlength (x) || index1 < index0)
4433 Error_1 ("substring: end out of bounds:", caddr (args)); 4721 Error_1 ("string->copy: end out of bounds:", caddr (args));
4434 } 4722 }
4435 else 4723 else
4436 index1 = strlength (x); 4724 index1 = strlength (x);
4437 4725
4438 len = index1 - index0; 4726 len = index1 - index0;
4439 x = mk_empty_string (SCHEME_A_ len, ' '); 4727 x = mk_counted_string (SCHEME_A_ str + index0, len);
4440 memcpy (strvalue (x), str + index0, len);
4441 strvalue (x)[len] = 0;
4442 4728
4443 s_return (x); 4729 s_return (x);
4444 } 4730 }
4445 4731
4446 case OP_VECTOR: /* vector */ 4732 case OP_VECTOR: /* vector */
… …
4520 } 4806 }
4521 4807
4522 if (USE_ERROR_CHECKING) abort (); 4808 if (USE_ERROR_CHECKING) abort ();
4523} 4809}
4524 4810
4525static int 4811/* relational ops */
4812ecb_hot static int
4526opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4813opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4527{ 4814{
4528 pointer x = SCHEME_V->args; 4815 pointer x = SCHEME_V->args;
4529 4816
4530 for (;;) 4817 for (;;)
… …
4551 } 4838 }
4552 4839
4553 s_return (S_T); 4840 s_return (S_T);
4554} 4841}
4555 4842
4556static int 4843/* predicates */
4844ecb_hot static int
4557opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4845opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4558{ 4846{
4559 pointer args = SCHEME_V->args; 4847 pointer args = SCHEME_V->args;
4560 pointer a = car (args); 4848 pointer a = car (args);
4561 pointer d = cdr (args); 4849 pointer d = cdr (args);
… …
4608 } 4896 }
4609 4897
4610 s_retbool (r); 4898 s_retbool (r);
4611} 4899}
4612 4900
4613static int 4901/* promises, list ops, ports */
4902ecb_hot static int
4614opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4903opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4615{ 4904{
4616 pointer args = SCHEME_V->args; 4905 pointer args = SCHEME_V->args;
4617 pointer a = car (args); 4906 pointer a = car (args);
4618 pointer x, y; 4907 pointer x, y;
… …
4631 } 4920 }
4632 else 4921 else
4633 s_return (SCHEME_V->code); 4922 s_return (SCHEME_V->code);
4634 4923
4635 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4924 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4636 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4925 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4637 s_return (SCHEME_V->value); 4926 s_return (SCHEME_V->value);
4638 4927
4639#if USE_PORTS 4928#if USE_PORTS
4929
4930 case OP_EOF_OBJECT: /* eof-object */
4931 s_return (S_EOF);
4640 4932
4641 case OP_WRITE: /* write */ 4933 case OP_WRITE: /* write */
4642 case OP_DISPLAY: /* display */ 4934 case OP_DISPLAY: /* display */
4643 case OP_WRITE_CHAR: /* write-char */ 4935 case OP_WRITE_CHAR: /* write-char */
4644 if (is_pair (cdr (SCHEME_V->args))) 4936 if (is_pair (cdr (SCHEME_V->args)))
… …
4658 else 4950 else
4659 SCHEME_V->print_flag = 0; 4951 SCHEME_V->print_flag = 0;
4660 4952
4661 s_goto (OP_P0LIST); 4953 s_goto (OP_P0LIST);
4662 4954
4955 //TODO: move to scheme
4663 case OP_NEWLINE: /* newline */ 4956 case OP_NEWLINE: /* newline */
4664 if (is_pair (args)) 4957 if (is_pair (args))
4665 { 4958 {
4666 if (a != SCHEME_V->outport) 4959 if (a != SCHEME_V->outport)
4667 { 4960 {
… …
4669 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4962 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4670 SCHEME_V->outport = a; 4963 SCHEME_V->outport = a;
4671 } 4964 }
4672 } 4965 }
4673 4966
4674 putstr (SCHEME_A_ "\n"); 4967 putcharacter (SCHEME_A_ '\n');
4675 s_return (S_T); 4968 s_return (S_T);
4676#endif 4969#endif
4677 4970
4678 case OP_ERR0: /* error */ 4971 case OP_ERR0: /* error */
4679 SCHEME_V->retcode = -1; 4972 SCHEME_V->retcode = -1;
… …
4688 putstr (SCHEME_A_ strvalue (car (args))); 4981 putstr (SCHEME_A_ strvalue (car (args)));
4689 SCHEME_V->args = cdr (args); 4982 SCHEME_V->args = cdr (args);
4690 s_goto (OP_ERR1); 4983 s_goto (OP_ERR1);
4691 4984
4692 case OP_ERR1: /* error */ 4985 case OP_ERR1: /* error */
4693 putstr (SCHEME_A_ " "); 4986 putcharacter (SCHEME_A_ ' ');
4694 4987
4695 if (args != NIL) 4988 if (args != NIL)
4696 { 4989 {
4697 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); 4990 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4698 SCHEME_V->args = a; 4991 SCHEME_V->args = a;
4699 SCHEME_V->print_flag = 1; 4992 SCHEME_V->print_flag = 1;
4700 s_goto (OP_P0LIST); 4993 s_goto (OP_P0LIST);
4701 } 4994 }
4702 else 4995 else
4703 { 4996 {
4704 putstr (SCHEME_A_ "\n"); 4997 putcharacter (SCHEME_A_ '\n');
4705 4998
4706 if (SCHEME_V->interactive_repl) 4999 if (SCHEME_V->interactive_repl)
4707 s_goto (OP_T0LVL); 5000 s_goto (OP_T0LVL);
4708 else 5001 else
4709 return -1; 5002 return -1;
… …
4786 SCHEME_V->gc_verbose = (a != S_F); 5079 SCHEME_V->gc_verbose = (a != S_F);
4787 s_retbool (was); 5080 s_retbool (was);
4788 } 5081 }
4789 5082
4790 case OP_NEWSEGMENT: /* new-segment */ 5083 case OP_NEWSEGMENT: /* new-segment */
5084#if 0
4791 if (!is_pair (args) || !is_number (a)) 5085 if (!is_pair (args) || !is_number (a))
4792 Error_0 ("new-segment: argument must be a number"); 5086 Error_0 ("new-segment: argument must be a number");
4793 5087#endif
4794 alloc_cellseg (SCHEME_A_ ivalue (a)); 5088 s_retbool (alloc_cellseg (SCHEME_A));
4795
4796 s_return (S_T);
4797 5089
4798 case OP_OBLIST: /* oblist */ 5090 case OP_OBLIST: /* oblist */
4799 s_return (oblist_all_symbols (SCHEME_A)); 5091 s_return (oblist_all_symbols (SCHEME_A));
4800 5092
4801#if USE_PORTS 5093#if USE_PORTS
… …
4871 s_return (p == NIL ? S_F : p); 5163 s_return (p == NIL ? S_F : p);
4872 } 5164 }
4873 5165
4874 case OP_GET_OUTSTRING: /* get-output-string */ 5166 case OP_GET_OUTSTRING: /* get-output-string */
4875 { 5167 {
4876 port *p; 5168 port *p = port (a);
4877 5169
4878 if ((p = a->object.port)->kind & port_string) 5170 if (p->kind & port_string)
4879 { 5171 {
4880 off_t size; 5172 off_t size;
4881 char *str; 5173 char *str;
4882 5174
4883 size = p->rep.string.curr - p->rep.string.start + 1; 5175 size = p->rep.string.curr - p->rep.string.start + 1;
… …
4918 } 5210 }
4919 5211
4920 if (USE_ERROR_CHECKING) abort (); 5212 if (USE_ERROR_CHECKING) abort ();
4921} 5213}
4922 5214
4923static int 5215/* reading */
5216ecb_cold static int
4924opexe_5 (SCHEME_P_ enum scheme_opcodes op) 5217opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4925{ 5218{
4926 pointer args = SCHEME_V->args; 5219 pointer args = SCHEME_V->args;
4927 pointer x; 5220 pointer x;
4928 5221
… …
4988 int res; 5281 int res;
4989 5282
4990 if (is_pair (args)) 5283 if (is_pair (args))
4991 p = car (args); 5284 p = car (args);
4992 5285
4993 res = p->object.port->kind & port_string; 5286 res = port (p)->kind & port_string;
4994 5287
4995 s_retbool (res); 5288 s_retbool (res);
4996 } 5289 }
4997 5290
4998 case OP_SET_INPORT: /* set-input-port */ 5291 case OP_SET_INPORT: /* set-input-port */
… …
5007 case OP_RDSEXPR: 5300 case OP_RDSEXPR:
5008 switch (SCHEME_V->tok) 5301 switch (SCHEME_V->tok)
5009 { 5302 {
5010 case TOK_EOF: 5303 case TOK_EOF:
5011 s_return (S_EOF); 5304 s_return (S_EOF);
5012 /* NOTREACHED */
5013 5305
5014 case TOK_VEC: 5306 case TOK_VEC:
5015 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL); 5307 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
5016 /* fall through */ 5308 /* fall through */
5017 5309
… …
5020 5312
5021 if (SCHEME_V->tok == TOK_RPAREN) 5313 if (SCHEME_V->tok == TOK_RPAREN)
5022 s_return (NIL); 5314 s_return (NIL);
5023 else if (SCHEME_V->tok == TOK_DOT) 5315 else if (SCHEME_V->tok == TOK_DOT)
5024 Error_0 ("syntax error: illegal dot expression"); 5316 Error_0 ("syntax error: illegal dot expression");
5025 else 5317
5026 {
5027 SCHEME_V->nesting_stack[SCHEME_V->file_i]++; 5318 SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
5028 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL); 5319 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
5029 s_goto (OP_RDSEXPR); 5320 s_goto (OP_RDSEXPR);
5030 }
5031 5321
5032 case TOK_QUOTE: 5322 case TOK_QUOTE:
5033 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL); 5323 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
5034 SCHEME_V->tok = token (SCHEME_A); 5324 SCHEME_V->tok = token (SCHEME_A);
5035 s_goto (OP_RDSEXPR); 5325 s_goto (OP_RDSEXPR);
… …
5041 { 5331 {
5042 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL); 5332 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5043 SCHEME_V->tok = TOK_LPAREN; 5333 SCHEME_V->tok = TOK_LPAREN;
5044 s_goto (OP_RDSEXPR); 5334 s_goto (OP_RDSEXPR);
5045 } 5335 }
5046 else 5336
5047 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); 5337 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5048
5049 s_goto (OP_RDSEXPR); 5338 s_goto (OP_RDSEXPR);
5050 5339
5051 case TOK_COMMA: 5340 case TOK_COMMA:
5052 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL); 5341 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
5053 SCHEME_V->tok = token (SCHEME_A); 5342 SCHEME_V->tok = token (SCHEME_A);
… …
5064 case TOK_DOTATOM: 5353 case TOK_DOTATOM:
5065 SCHEME_V->strbuff[0] = '.'; 5354 SCHEME_V->strbuff[0] = '.';
5066 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); 5355 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5067 5356
5068 case TOK_STRATOM: 5357 case TOK_STRATOM:
5358 //TODO: haven't checked whether the garbage collector could interfere and free x
5359 gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded
5069 x = readstrexp (SCHEME_A_ '|'); 5360 x = readstrexp (SCHEME_A_ '|');
5070 //TODO: haven't checked whether the garbage collector could interfere
5071 s_return (mk_atom (SCHEME_A_ strvalue (x))); 5361 s_return (mk_atom (SCHEME_A_ strvalue (x)));
5072 5362
5073 case TOK_DQUOTE: 5363 case TOK_DQUOTE:
5074 x = readstrexp (SCHEME_A_ '"'); 5364 x = readstrexp (SCHEME_A_ '"');
5075 5365
… …
5083 { 5373 {
5084 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1); 5374 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);
5085 5375
5086 if (f == NIL) 5376 if (f == NIL)
5087 Error_0 ("undefined sharp expression"); 5377 Error_0 ("undefined sharp expression");
5088 else 5378
5089 {
5090 SCHEME_V->code = cons (slot_value_in_env (f), NIL); 5379 SCHEME_V->code = cons (slot_value_in_env (f), NIL);
5091 s_goto (OP_EVAL); 5380 s_goto (OP_EVAL);
5092 }
5093 } 5381 }
5094 5382
5095 case TOK_SHARP_CONST: 5383 case TOK_SHARP_CONST:
5096 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL) 5384 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5097 Error_0 ("undefined sharp expression"); 5385 Error_0 ("undefined sharp expression");
5098 else 5386
5099 s_return (x); 5387 s_return (x);
5100 5388
5101 default: 5389 default:
5102 Error_0 ("syntax error: illegal token"); 5390 Error_0 ("syntax error: illegal token");
5103 } 5391 }
5104 5392
… …
5197 pointer b = cdr (args); 5485 pointer b = cdr (args);
5198 int ok_abbr = ok_abbrev (b); 5486 int ok_abbr = ok_abbrev (b);
5199 SCHEME_V->args = car (b); 5487 SCHEME_V->args = car (b);
5200 5488
5201 if (a == SCHEME_V->QUOTE && ok_abbr) 5489 if (a == SCHEME_V->QUOTE && ok_abbr)
5202 putstr (SCHEME_A_ "'"); 5490 putcharacter (SCHEME_A_ '\'');
5203 else if (a == SCHEME_V->QQUOTE && ok_abbr) 5491 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5204 putstr (SCHEME_A_ "`"); 5492 putcharacter (SCHEME_A_ '`');
5205 else if (a == SCHEME_V->UNQUOTE && ok_abbr) 5493 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5206 putstr (SCHEME_A_ ","); 5494 putcharacter (SCHEME_A_ ',');
5207 else if (a == SCHEME_V->UNQUOTESP && ok_abbr) 5495 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5208 putstr (SCHEME_A_ ",@"); 5496 putstr (SCHEME_A_ ",@");
5209 else 5497 else
5210 { 5498 {
5211 putstr (SCHEME_A_ "("); 5499 putcharacter (SCHEME_A_ '(');
5212 s_save (SCHEME_A_ OP_P1LIST, b, NIL); 5500 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5213 SCHEME_V->args = a; 5501 SCHEME_V->args = a;
5214 } 5502 }
5215 5503
5216 s_goto (OP_P0LIST); 5504 s_goto (OP_P0LIST);
… …
5218 5506
5219 case OP_P1LIST: 5507 case OP_P1LIST:
5220 if (is_pair (args)) 5508 if (is_pair (args))
5221 { 5509 {
5222 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); 5510 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5223 putstr (SCHEME_A_ " "); 5511 putcharacter (SCHEME_A_ ' ');
5224 SCHEME_V->args = car (args); 5512 SCHEME_V->args = car (args);
5225 s_goto (OP_P0LIST); 5513 s_goto (OP_P0LIST);
5226 } 5514 }
5227 else if (is_vector (args)) 5515 else if (is_vector (args))
5228 { 5516 {
… …
5236 { 5524 {
5237 putstr (SCHEME_A_ " . "); 5525 putstr (SCHEME_A_ " . ");
5238 printatom (SCHEME_A_ args, SCHEME_V->print_flag); 5526 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5239 } 5527 }
5240 5528
5241 putstr (SCHEME_A_ ")"); 5529 putcharacter (SCHEME_A_ ')');
5242 s_return (S_T); 5530 s_return (S_T);
5243 } 5531 }
5244 5532
5245 case OP_PVECFROM: 5533 case OP_PVECFROM:
5246 { 5534 {
… …
5248 pointer vec = car (args); 5536 pointer vec = car (args);
5249 int len = veclength (vec); 5537 int len = veclength (vec);
5250 5538
5251 if (i == len) 5539 if (i == len)
5252 { 5540 {
5253 putstr (SCHEME_A_ ")"); 5541 putcharacter (SCHEME_A_ ')');
5254 s_return (S_T); 5542 s_return (S_T);
5255 } 5543 }
5256 else 5544 else
5257 { 5545 {
5258 pointer elem = vector_get (vec, i); 5546 pointer elem = vector_get (vec, i);
… …
5260 ivalue_unchecked (cdr (args)) = i + 1; 5548 ivalue_unchecked (cdr (args)) = i + 1;
5261 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5549 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5262 SCHEME_V->args = elem; 5550 SCHEME_V->args = elem;
5263 5551
5264 if (i > 0) 5552 if (i > 0)
5265 putstr (SCHEME_A_ " "); 5553 putcharacter (SCHEME_A_ ' ');
5266 5554
5267 s_goto (OP_P0LIST); 5555 s_goto (OP_P0LIST);
5268 } 5556 }
5269 } 5557 }
5270 } 5558 }
5271 5559
5272 if (USE_ERROR_CHECKING) abort (); 5560 if (USE_ERROR_CHECKING) abort ();
5273} 5561}
5274 5562
5275static int 5563/* list ops */
5564ecb_hot static int
5276opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5565opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5277{ 5566{
5278 pointer args = SCHEME_V->args; 5567 pointer args = SCHEME_V->args;
5279 pointer a = car (args); 5568 pointer a = car (args);
5280 pointer x, y; 5569 pointer x, y;
… …
5303 break; 5592 break;
5304 } 5593 }
5305 5594
5306 if (is_pair (y)) 5595 if (is_pair (y))
5307 s_return (car (y)); 5596 s_return (car (y));
5308 else 5597
5309 s_return (S_F); 5598 s_return (S_F);
5310
5311 5599
5312 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5600 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5313 SCHEME_V->args = a; 5601 SCHEME_V->args = a;
5314 5602
5315 if (SCHEME_V->args == NIL) 5603 if (SCHEME_V->args == NIL)
5316 s_return (S_F); 5604 s_return (S_F);
5317 else if (is_closure (SCHEME_V->args)) 5605 else if (is_closure (SCHEME_V->args) || is_macro (SCHEME_V->args))
5318 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5606 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5319 else if (is_macro (SCHEME_V->args)) 5607
5320 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5321 else
5322 s_return (S_F); 5608 s_return (S_F);
5323 5609
5324 case OP_CLOSUREP: /* closure? */ 5610 case OP_CLOSUREP: /* closure? */
5325 /* 5611 /*
5326 * Note, macro object is also a closure. 5612 * Note, macro object is also a closure.
5327 * Therefore, (closure? <#MACRO>) ==> #t 5613 * Therefore, (closure? <#MACRO>) ==> #t
… …
5338 5624
5339/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5625/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5340typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); 5626typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5341 5627
5342typedef int (*test_predicate)(pointer); 5628typedef int (*test_predicate)(pointer);
5343static int 5629
5630ecb_hot static int
5344tst_any (pointer p) 5631tst_any (pointer p)
5345{ 5632{
5346 return 1; 5633 return 1;
5347} 5634}
5348 5635
5349static int 5636ecb_hot static int
5350tst_inonneg (pointer p) 5637tst_inonneg (pointer p)
5351{ 5638{
5352 return is_integer (p) && ivalue_unchecked (p) >= 0; 5639 return is_integer (p) && ivalue_unchecked (p) >= 0;
5353} 5640}
5354 5641
5355static int 5642ecb_hot static int
5356tst_is_list (SCHEME_P_ pointer p) 5643tst_is_list (SCHEME_P_ pointer p)
5357{ 5644{
5358 return p == NIL || is_pair (p); 5645 return p == NIL || is_pair (p);
5359} 5646}
5360 5647
… …
5403#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" 5690#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5404#include "opdefines.h" 5691#include "opdefines.h"
5405#undef OP_DEF 5692#undef OP_DEF
5406; 5693;
5407 5694
5408static const char * 5695ecb_cold static const char *
5409opname (int idx) 5696opname (int idx)
5410{ 5697{
5411 const char *name = opnames; 5698 const char *name = opnames;
5412 5699
5413 /* should do this at compile time, but would require external program, right? */ 5700 /* should do this at compile time, but would require external program, right? */
… …
5415 name += strlen (name) + 1; 5702 name += strlen (name) + 1;
5416 5703
5417 return *name ? name : "ILLEGAL"; 5704 return *name ? name : "ILLEGAL";
5418} 5705}
5419 5706
5420static const char * 5707ecb_cold static const char *
5421procname (pointer x) 5708procname (pointer x)
5422{ 5709{
5423 return opname (procnum (x)); 5710 return opname (procnum (x));
5424} 5711}
5425 5712
… …
5445#undef OP_DEF 5732#undef OP_DEF
5446 {0} 5733 {0}
5447}; 5734};
5448 5735
5449/* kernel of this interpreter */ 5736/* kernel of this interpreter */
5450static void ecb_hot 5737ecb_hot static void
5451Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5738Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5452{ 5739{
5453 SCHEME_V->op = op; 5740 SCHEME_V->op = op;
5454 5741
5455 for (;;) 5742 for (;;)
… …
5538 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) 5825 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5539 return; 5826 return;
5540 5827
5541 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5828 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5542 { 5829 {
5543 xwrstr ("No memory!\n"); 5830 putstr (SCHEME_A_ "No memory!\n");
5544 return; 5831 return;
5545 } 5832 }
5546 } 5833 }
5547} 5834}
5548 5835
5549/* ========== Initialization of internal keywords ========== */ 5836/* ========== Initialization of internal keywords ========== */
5550 5837
5551static void 5838ecb_cold static void
5552assign_syntax (SCHEME_P_ const char *name) 5839assign_syntax (SCHEME_P_ const char *name)
5553{ 5840{
5554 pointer x = oblist_add_by_name (SCHEME_A_ name); 5841 pointer x = oblist_add_by_name (SCHEME_A_ name);
5555 set_typeflag (x, typeflag (x) | T_SYNTAX); 5842 set_typeflag (x, typeflag (x) | T_SYNTAX);
5556} 5843}
5557 5844
5558static void 5845ecb_cold static void
5559assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5846assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5560{ 5847{
5561 pointer x = mk_symbol (SCHEME_A_ name); 5848 pointer x = mk_symbol (SCHEME_A_ name);
5562 pointer y = mk_proc (SCHEME_A_ op); 5849 pointer y = mk_proc (SCHEME_A_ op);
5563 new_slot_in_env (SCHEME_A_ x, y); 5850 new_slot_in_env (SCHEME_A_ x, y);
… …
5571 ivalue_unchecked (y) = op; 5858 ivalue_unchecked (y) = op;
5572 return y; 5859 return y;
5573} 5860}
5574 5861
5575/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5862/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5576static int 5863ecb_hot static int
5577syntaxnum (pointer p) 5864syntaxnum (pointer p)
5578{ 5865{
5579 const char *s = strvalue (p); 5866 const char *s = strvalue (p);
5580 5867
5581 switch (strlength (p)) 5868 switch (strlength (p))
… …
5661ecb_cold int 5948ecb_cold int
5662scheme_init (SCHEME_P) 5949scheme_init (SCHEME_P)
5663{ 5950{
5664 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5951 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5665 pointer x; 5952 pointer x;
5953
5954 /* this memset is not strictly correct, as we assume (intcache)
5955 * that memset 0 will also set pointers to 0, but memset does
5956 * of course not guarantee that. screw such systems.
5957 */
5958 memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5666 5959
5667 num_set_fixnum (num_zero, 1); 5960 num_set_fixnum (num_zero, 1);
5668 num_set_ivalue (num_zero, 0); 5961 num_set_ivalue (num_zero, 0);
5669 num_set_fixnum (num_one, 1); 5962 num_set_fixnum (num_one, 1);
5670 num_set_ivalue (num_one, 1); 5963 num_set_ivalue (num_one, 1);
… …
5682 SCHEME_V->save_inport = NIL; 5975 SCHEME_V->save_inport = NIL;
5683 SCHEME_V->loadport = NIL; 5976 SCHEME_V->loadport = NIL;
5684 SCHEME_V->nesting = 0; 5977 SCHEME_V->nesting = 0;
5685 SCHEME_V->interactive_repl = 0; 5978 SCHEME_V->interactive_repl = 0;
5686 5979
5687 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 5980 if (!alloc_cellseg (SCHEME_A))
5688 { 5981 {
5689#if USE_ERROR_CHECKING 5982#if USE_ERROR_CHECKING
5690 SCHEME_V->no_memory = 1; 5983 SCHEME_V->no_memory = 1;
5691 return 0; 5984 return 0;
5692#endif 5985#endif
5693 } 5986 }
5694 5987
5695 SCHEME_V->gc_verbose = 0; 5988 SCHEME_V->gc_verbose = 0;
5696 dump_stack_initialize (SCHEME_A); 5989 dump_stack_initialize (SCHEME_A);
5697 SCHEME_V->code = NIL; 5990 SCHEME_V->code = NIL;
5698 SCHEME_V->args = NIL; 5991 SCHEME_V->args = NIL;
5699 SCHEME_V->envir = NIL; 5992 SCHEME_V->envir = NIL;
5993 SCHEME_V->value = NIL;
5700 SCHEME_V->tracing = 0; 5994 SCHEME_V->tracing = 0;
5701 5995
5702 /* init NIL */ 5996 /* init NIL */
5703 set_typeflag (NIL, T_ATOM | T_MARK); 5997 set_typeflag (NIL, T_ATOM | T_MARK);
5704 set_car (NIL, NIL); 5998 set_car (NIL, NIL);
… …
5760 6054
5761 return !SCHEME_V->no_memory; 6055 return !SCHEME_V->no_memory;
5762} 6056}
5763 6057
5764#if USE_PORTS 6058#if USE_PORTS
5765void 6059ecb_cold void
5766scheme_set_input_port_file (SCHEME_P_ int fin) 6060scheme_set_input_port_file (SCHEME_P_ int fin)
5767{ 6061{
5768 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 6062 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5769} 6063}
5770 6064
5771void 6065ecb_cold void
5772scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 6066scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5773{ 6067{
5774 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 6068 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5775} 6069}
5776 6070
5777void 6071ecb_cold void
5778scheme_set_output_port_file (SCHEME_P_ int fout) 6072scheme_set_output_port_file (SCHEME_P_ int fout)
5779{ 6073{
5780 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 6074 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5781} 6075}
5782 6076
5783void 6077ecb_cold void
5784scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 6078scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5785{ 6079{
5786 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 6080 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5787} 6081}
5788#endif 6082#endif
5789 6083
5790void 6084ecb_cold void
5791scheme_set_external_data (SCHEME_P_ void *p) 6085scheme_set_external_data (SCHEME_P_ void *p)
5792{ 6086{
5793 SCHEME_V->ext_data = p; 6087 SCHEME_V->ext_data = p;
5794} 6088}
5795 6089
… …
5827 SCHEME_V->loadport = NIL; 6121 SCHEME_V->loadport = NIL;
5828 SCHEME_V->gc_verbose = 0; 6122 SCHEME_V->gc_verbose = 0;
5829 gc (SCHEME_A_ NIL, NIL); 6123 gc (SCHEME_A_ NIL, NIL);
5830 6124
5831 for (i = 0; i <= SCHEME_V->last_cell_seg; i++) 6125 for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5832 free (SCHEME_V->alloc_seg[i]); 6126 free (SCHEME_V->cell_seg[i]);
5833 6127
5834#if SHOW_ERROR_LINE 6128#if SHOW_ERROR_LINE
5835 for (i = 0; i <= SCHEME_V->file_i; i++) 6129 for (i = 0; i <= SCHEME_V->file_i; i++)
5836 {
5837 if (SCHEME_V->load_stack[i].kind & port_file) 6130 if (SCHEME_V->load_stack[i].kind & port_file)
5838 { 6131 {
5839 fname = SCHEME_V->load_stack[i].rep.stdio.filename; 6132 fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5840 6133
5841 if (fname) 6134 if (fname)
5842 free (fname); 6135 free (fname);
5843 } 6136 }
5844 }
5845#endif 6137#endif
5846} 6138}
5847 6139
5848void 6140ecb_cold void
5849scheme_load_file (SCHEME_P_ int fin) 6141scheme_load_file (SCHEME_P_ int fin)
5850{ 6142{
5851 scheme_load_named_file (SCHEME_A_ fin, 0); 6143 scheme_load_named_file (SCHEME_A_ fin, 0);
5852} 6144}
5853 6145
5854void 6146ecb_cold void
5855scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 6147scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5856{ 6148{
5857 dump_stack_reset (SCHEME_A); 6149 dump_stack_reset (SCHEME_A);
5858 SCHEME_V->envir = SCHEME_V->global_env; 6150 SCHEME_V->envir = SCHEME_V->global_env;
5859 SCHEME_V->file_i = 0; 6151 SCHEME_V->file_i = 0;
5860 SCHEME_V->load_stack[0].unget = -1; 6152 SCHEME_V->load_stack[0].unget = -1;
5861 SCHEME_V->load_stack[0].kind = port_input | port_file; 6153 SCHEME_V->load_stack[0].kind = port_input | port_file;
5862 SCHEME_V->load_stack[0].rep.stdio.file = fin; 6154 SCHEME_V->load_stack[0].rep.stdio.file = fin;
5863#if USE_PORTS
5864 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 6155 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5865#endif
5866 SCHEME_V->retcode = 0; 6156 SCHEME_V->retcode = 0;
5867 6157
5868#if USE_PORTS
5869 if (fin == STDIN_FILENO) 6158 if (fin == STDIN_FILENO)
5870 SCHEME_V->interactive_repl = 1; 6159 SCHEME_V->interactive_repl = 1;
5871#endif
5872 6160
5873#if USE_PORTS 6161#if USE_PORTS
5874#if SHOW_ERROR_LINE 6162#if SHOW_ERROR_LINE
5875 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0; 6163 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5876 6164
… …
5880#endif 6168#endif
5881 6169
5882 SCHEME_V->inport = SCHEME_V->loadport; 6170 SCHEME_V->inport = SCHEME_V->loadport;
5883 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6171 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5884 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6172 Eval_Cycle (SCHEME_A_ OP_T0LVL);
6173
5885 set_typeflag (SCHEME_V->loadport, T_ATOM); 6174 set_typeflag (SCHEME_V->loadport, T_ATOM);
5886 6175
5887 if (SCHEME_V->retcode == 0) 6176 if (SCHEME_V->retcode == 0)
5888 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6177 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5889} 6178}
5890 6179
5891void 6180ecb_cold void
5892scheme_load_string (SCHEME_P_ const char *cmd) 6181scheme_load_string (SCHEME_P_ const char *cmd)
5893{ 6182{
6183#if USE_PORTs
5894 dump_stack_reset (SCHEME_A); 6184 dump_stack_reset (SCHEME_A);
5895 SCHEME_V->envir = SCHEME_V->global_env; 6185 SCHEME_V->envir = SCHEME_V->global_env;
5896 SCHEME_V->file_i = 0; 6186 SCHEME_V->file_i = 0;
5897 SCHEME_V->load_stack[0].kind = port_input | port_string; 6187 SCHEME_V->load_stack[0].kind = port_input | port_string;
5898 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ 6188 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5899 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); 6189 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5900 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; 6190 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5901#if USE_PORTS
5902 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 6191 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5903#endif
5904 SCHEME_V->retcode = 0; 6192 SCHEME_V->retcode = 0;
5905 SCHEME_V->interactive_repl = 0; 6193 SCHEME_V->interactive_repl = 0;
5906 SCHEME_V->inport = SCHEME_V->loadport; 6194 SCHEME_V->inport = SCHEME_V->loadport;
5907 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6195 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5908 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6196 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5909 set_typeflag (SCHEME_V->loadport, T_ATOM); 6197 set_typeflag (SCHEME_V->loadport, T_ATOM);
5910 6198
5911 if (SCHEME_V->retcode == 0) 6199 if (SCHEME_V->retcode == 0)
5912 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6200 SCHEME_V->retcode = SCHEME_V->nesting != 0;
6201#else
6202 abort ();
6203#endif
5913} 6204}
5914 6205
5915void 6206ecb_cold void
5916scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 6207scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5917{ 6208{
5918 pointer x; 6209 pointer x;
5919 6210
5920 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 6211 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5925 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 6216 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5926} 6217}
5927 6218
5928#if !STANDALONE 6219#if !STANDALONE
5929 6220
5930void 6221ecb_cold void
5931scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 6222scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5932{ 6223{
5933 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 6224 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5934} 6225}
5935 6226
5936void 6227ecb_cold void
5937scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 6228scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5938{ 6229{
5939 int i; 6230 int i;
5940 6231
5941 for (i = 0; i < count; i++) 6232 for (i = 0; i < count; i++)
5942 scheme_register_foreign_func (SCHEME_A_ list + i); 6233 scheme_register_foreign_func (SCHEME_A_ list + i);
5943} 6234}
5944 6235
5945pointer 6236ecb_cold pointer
5946scheme_apply0 (SCHEME_P_ const char *procname) 6237scheme_apply0 (SCHEME_P_ const char *procname)
5947{ 6238{
5948 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 6239 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5949} 6240}
5950 6241
5951void 6242ecb_cold void
5952save_from_C_call (SCHEME_P) 6243save_from_C_call (SCHEME_P)
5953{ 6244{
5954 pointer saved_data = cons (car (S_SINK), 6245 pointer saved_data = cons (car (S_SINK),
5955 cons (SCHEME_V->envir, 6246 cons (SCHEME_V->envir,
5956 SCHEME_V->dump)); 6247 SCHEME_V->dump));
… …
5960 /* Truncate the dump stack so TS will return here when done, not 6251 /* Truncate the dump stack so TS will return here when done, not
5961 directly resume pre-C-call operations. */ 6252 directly resume pre-C-call operations. */
5962 dump_stack_reset (SCHEME_A); 6253 dump_stack_reset (SCHEME_A);
5963} 6254}
5964 6255
5965void 6256ecb_cold void
5966restore_from_C_call (SCHEME_P) 6257restore_from_C_call (SCHEME_P)
5967{ 6258{
5968 set_car (S_SINK, caar (SCHEME_V->c_nest)); 6259 set_car (S_SINK, caar (SCHEME_V->c_nest));
5969 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 6260 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5970 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 6261 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5971 /* Pop */ 6262 /* Pop */
5972 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 6263 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5973} 6264}
5974 6265
5975/* "func" and "args" are assumed to be already eval'ed. */ 6266/* "func" and "args" are assumed to be already eval'ed. */
5976pointer 6267ecb_cold pointer
5977scheme_call (SCHEME_P_ pointer func, pointer args) 6268scheme_call (SCHEME_P_ pointer func, pointer args)
5978{ 6269{
5979 int old_repl = SCHEME_V->interactive_repl; 6270 int old_repl = SCHEME_V->interactive_repl;
5980 6271
5981 SCHEME_V->interactive_repl = 0; 6272 SCHEME_V->interactive_repl = 0;
… …
5988 SCHEME_V->interactive_repl = old_repl; 6279 SCHEME_V->interactive_repl = old_repl;
5989 restore_from_C_call (SCHEME_A); 6280 restore_from_C_call (SCHEME_A);
5990 return SCHEME_V->value; 6281 return SCHEME_V->value;
5991} 6282}
5992 6283
5993pointer 6284ecb_cold pointer
5994scheme_eval (SCHEME_P_ pointer obj) 6285scheme_eval (SCHEME_P_ pointer obj)
5995{ 6286{
5996 int old_repl = SCHEME_V->interactive_repl; 6287 int old_repl = SCHEME_V->interactive_repl;
5997 6288
5998 SCHEME_V->interactive_repl = 0; 6289 SCHEME_V->interactive_repl = 0;
… …
6010 6301
6011/* ========== Main ========== */ 6302/* ========== Main ========== */
6012 6303
6013#if STANDALONE 6304#if STANDALONE
6014 6305
6015int 6306ecb_cold int
6016main (int argc, char **argv) 6307main (int argc, char **argv)
6017{ 6308{
6018# if USE_MULTIPLICITY 6309# if USE_MULTIPLICITY
6019 scheme ssc; 6310 scheme ssc;
6020 scheme *const SCHEME_V = &ssc; 6311 scheme *const SCHEME_V = &ssc;
… …
6022# endif 6313# endif
6023 int fin; 6314 int fin;
6024 char *file_name = InitFile; 6315 char *file_name = InitFile;
6025 int retcode; 6316 int retcode;
6026 int isfile = 1; 6317 int isfile = 1;
6318#if EXPERIMENT
6027 system ("ps v $PPID");//D 6319 system ("ps v $PPID");
6320#endif
6028 6321
6029 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6322 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6030 { 6323 {
6031 xwrstr ("Usage: tinyscheme -?\n"); 6324 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6032 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6325 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6033 xwrstr ("followed by\n"); 6326 putstr (SCHEME_A_ "followed by\n");
6034 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6327 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6035 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6328 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6036 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6329 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6037 xwrstr ("Use - as filename for stdin.\n"); 6330 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6038 return 1; 6331 return 1;
6039 } 6332 }
6040 6333
6041 if (!scheme_init (SCHEME_A)) 6334 if (!scheme_init (SCHEME_A))
6042 { 6335 {
6043 xwrstr ("Could not initialize!\n"); 6336 putstr (SCHEME_A_ "Could not initialize!\n");
6044 return 2; 6337 return 2;
6045 } 6338 }
6046 6339
6047# if USE_PORTS 6340# if USE_PORTS
6048 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6341 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6061 } 6354 }
6062#endif 6355#endif
6063 6356
6064 do 6357 do
6065 { 6358 {
6066#if USE_PORTS
6067 if (strcmp (file_name, "-") == 0) 6359 if (strcmp (file_name, "-") == 0)
6068 fin = STDIN_FILENO; 6360 fin = STDIN_FILENO;
6069 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) 6361 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
6070 { 6362 {
6071 pointer args = NIL; 6363 pointer args = NIL;
… …
6089 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args); 6381 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
6090 6382
6091 } 6383 }
6092 else 6384 else
6093 fin = open (file_name, O_RDONLY); 6385 fin = open (file_name, O_RDONLY);
6094#endif
6095 6386
6096 if (isfile && fin < 0) 6387 if (isfile && fin < 0)
6097 { 6388 {
6098 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6389 putstr (SCHEME_A_ "Could not open file ");
6390 putstr (SCHEME_A_ file_name);
6391 putcharacter (SCHEME_A_ '\n');
6099 } 6392 }
6100 else 6393 else
6101 { 6394 {
6102 if (isfile) 6395 if (isfile)
6103 scheme_load_named_file (SCHEME_A_ fin, file_name); 6396 scheme_load_named_file (SCHEME_A_ fin, file_name);
6104 else 6397 else
6105 scheme_load_string (SCHEME_A_ file_name); 6398 scheme_load_string (SCHEME_A_ file_name);
6106 6399
6107#if USE_PORTS
6108 if (!isfile || fin != STDIN_FILENO) 6400 if (!isfile || fin != STDIN_FILENO)
6109 { 6401 {
6110 if (SCHEME_V->retcode != 0) 6402 if (SCHEME_V->retcode != 0)
6111 { 6403 {
6112 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6404 putstr (SCHEME_A_ "Errors encountered reading ");
6405 putstr (SCHEME_A_ file_name);
6406 putcharacter (SCHEME_A_ '\n');
6113 } 6407 }
6114 6408
6115 if (isfile) 6409 if (isfile)
6116 close (fin); 6410 close (fin);
6117 } 6411 }
6118#endif
6119 } 6412 }
6120 6413
6121 file_name = *argv++; 6414 file_name = *argv++;
6122 } 6415 }
6123 while (file_name != 0); 6416 while (file_name != 0);

Diff Legend

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