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.48 by root, Mon Nov 30 13:07:34 2015 UTC vs.
Revision 1.63 by root, Wed Dec 2 12:16:24 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 _GNU_SOURCE 1
22#define _POSIX_C_SOURCE 200201
23#define _XOPEN_SOURCE 600
22 24
23#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
24#include "malloc.c"
25 25
26#define SCHEME_SOURCE 26#define SCHEME_SOURCE
27#include "scheme-private.h" 27#include "scheme-private.h"
28#ifndef WIN32 28#ifndef WIN32
29# include <unistd.h> 29# include <unistd.h>
30#endif 30#endif
31#if USE_MATH 31#if USE_MATH
32# include <math.h> 32# include <math.h>
33#endif 33#endif
34 34
35#define ECB_NO_THREADS 1
35#include "ecb.h" 36#include "ecb.h"
36 37
37#include <sys/types.h> 38#include <sys/types.h>
38#include <sys/stat.h> 39#include <sys/stat.h>
39#include <fcntl.h> 40#include <fcntl.h>
… …
47#include <string.h> 48#include <string.h>
48 49
49#include <limits.h> 50#include <limits.h>
50#include <inttypes.h> 51#include <inttypes.h>
51#include <float.h> 52#include <float.h>
52//#include <ctype.h> 53
54#if !USE_SYSTEM_MALLOC
55# define PAGE_SIZE 4096 /* does not work on sparc/alpha */
56# include "malloc.c"
57# define malloc(n) tiny_malloc (n)
58# define realloc(p,n) tiny_realloc (p, n)
59# define free(p) tiny_free (p)
60#endif
53 61
54#if '1' != '0' + 1 \ 62#if '1' != '0' + 1 \
55 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \ 63 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
56 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \ 64 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
57 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \ 65 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
… …
79 87
80#define BACKQUOTE '`' 88#define BACKQUOTE '`'
81#define WHITESPACE " \t\r\n\v\f" 89#define WHITESPACE " \t\r\n\v\f"
82#define DELIMITERS "()\";" WHITESPACE 90#define DELIMITERS "()\";" WHITESPACE
83 91
84#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 92#define NIL POINTER (&SCHEME_V->xNIL)
85#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 93#define S_T POINTER (&SCHEME_V->xT)
86#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 94#define S_F POINTER (&SCHEME_V->xF)
87#define S_SINK (&SCHEME_V->xsink) 95#define S_SINK POINTER (&SCHEME_V->xsink)
88#define S_EOF (&SCHEME_V->xEOF_OBJ) 96#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
89 97
90#if !USE_MULTIPLICITY 98#if !USE_MULTIPLICITY
91static scheme sc; 99static scheme sc;
92#endif 100#endif
93 101
94static void 102ecb_cold static void
95xbase (char *s, long n, int base) 103xbase (char *s, long n, int base)
96{ 104{
97 if (n < 0) 105 if (n < 0)
98 { 106 {
99 *s++ = '-'; 107 *s++ = '-';
… …
101 } 109 }
102 110
103 char *p = s; 111 char *p = s;
104 112
105 do { 113 do {
106 *p++ = '0' + n % base; 114 *p++ = "0123456789abcdef"[n % base];
107 n /= base; 115 n /= base;
108 } while (n); 116 } while (n);
109 117
110 *p-- = 0; 118 *p-- = 0;
111 119
… …
114 char x = *s; *s = *p; *p = x; 122 char x = *s; *s = *p; *p = x;
115 --p; ++s; 123 --p; ++s;
116 } 124 }
117} 125}
118 126
119static void 127ecb_cold static void
120xnum (char *s, long n) 128xnum (char *s, long n)
121{ 129{
122 xbase (s, n, 10); 130 xbase (s, n, 10);
123} 131}
124 132
125static void 133ecb_cold static void
126xwrstr (const char *s) 134putnum (SCHEME_P_ long n)
127{
128 write (1, s, strlen (s));
129}
130
131static void
132xwrnum (long n)
133{ 135{
134 char buf[64]; 136 char buf[64];
135 137
136 xnum (buf, n); 138 xnum (buf, n);
137 xwrstr (buf); 139 putstr (SCHEME_A_ buf);
138} 140}
141
142#if USE_CHAR_CLASSIFIERS
143#include <ctype.h>
144#else
139 145
140static char 146static char
141xtoupper (char c) 147xtoupper (char c)
142{ 148{
143 if (c >= 'a' && c <= 'z') 149 if (c >= 'a' && c <= 'z')
… …
163 169
164#define toupper(c) xtoupper (c) 170#define toupper(c) xtoupper (c)
165#define tolower(c) xtolower (c) 171#define tolower(c) xtolower (c)
166#define isdigit(c) xisdigit (c) 172#define isdigit(c) xisdigit (c)
167 173
174#endif
175
168#if USE_IGNORECASE 176#if USE_IGNORECASE
169static const char * 177ecb_cold static const char *
170xstrlwr (char *s) 178xstrlwr (char *s)
171{ 179{
172 const char *p = s; 180 const char *p = s;
173 181
174 while (*s) 182 while (*s)
… …
187# define stricmp(a,b) strcmp (a, b) 195# define stricmp(a,b) strcmp (a, b)
188# define strlwr(s) (s) 196# define strlwr(s) (s)
189#endif 197#endif
190 198
191#ifndef prompt 199#ifndef prompt
192# define prompt "ts> " 200# define prompt "ms> "
193#endif 201#endif
194 202
195#ifndef InitFile 203#ifndef InitFile
196# define InitFile "init.scm" 204# define InitFile "init.scm"
197#endif 205#endif
198 206
199#ifndef FIRST_CELLSEGS
200# define FIRST_CELLSEGS 3
201#endif
202
203enum scheme_types 207enum scheme_types
204{ 208{
205 T_INTEGER, 209 T_INTEGER,
210 T_CHARACTER,
206 T_REAL, 211 T_REAL,
207 T_STRING, 212 T_STRING,
208 T_SYMBOL, 213 T_SYMBOL,
209 T_PROC, 214 T_PROC,
210 T_PAIR, /* also used for free cells */ 215 T_PAIR, /* also used for free cells */
211 T_CLOSURE, 216 T_CLOSURE,
217 T_BYTECODE, // temp
218 T_MACRO,
212 T_CONTINUATION, 219 T_CONTINUATION,
213 T_FOREIGN, 220 T_FOREIGN,
214 T_CHARACTER,
215 T_PORT, 221 T_PORT,
216 T_VECTOR, 222 T_VECTOR,
217 T_MACRO,
218 T_PROMISE, 223 T_PROMISE,
219 T_ENVIRONMENT, 224 T_ENVIRONMENT,
220 /* one more... */ 225
221 T_NUM_SYSTEM_TYPES 226 T_NUM_SYSTEM_TYPES
222}; 227};
223 228
224#define T_MASKTYPE 0x000f 229#define T_MASKTYPE 0x000f
225#define T_SYNTAX 0x0010 230#define T_SYNTAX 0x0010
… …
258static num num_op (enum num_op op, num a, num b); 263static num num_op (enum num_op op, num a, num b);
259static num num_intdiv (num a, num b); 264static num num_intdiv (num a, num b);
260static num num_rem (num a, num b); 265static num num_rem (num a, num b);
261static num num_mod (num a, num b); 266static num num_mod (num a, num b);
262 267
263#if USE_MATH
264static double round_per_R5RS (double x);
265#endif
266static int is_zero_rvalue (RVALUE x); 268static int is_zero_rvalue (RVALUE x);
267 269
268static num num_zero; 270static num num_zero;
269static num num_one; 271static num num_one;
270 272
273/* convert "pointer" to cell* / cell* to pointer */
274#define CELL(p) ((struct cell *)(p) + 0)
275#define POINTER(c) ((void *)((c) - 0))
276
271/* macros for cell operations */ 277/* macros for cell operations */
272#define typeflag(p) ((p)->flag + 0) 278#define typeflag(p) (CELL(p)->flag + 0)
273#define set_typeflag(p,v) ((p)->flag = (v)) 279#define set_typeflag(p,v) (CELL(p)->flag = (v))
274#define type(p) (typeflag (p) & T_MASKTYPE) 280#define type(p) (typeflag (p) & T_MASKTYPE)
275 281
276INTERFACE int 282INTERFACE int
277is_string (pointer p) 283is_string (pointer p)
278{ 284{
279 return type (p) == T_STRING; 285 return type (p) == T_STRING;
280} 286}
281 287
282#define strvalue(p) ((p)->object.string.svalue) 288#define strvalue(p) (CELL(p)->object.string.svalue)
283#define strlength(p) ((p)->object.string.length) 289#define strlength(p) (CELL(p)->object.string.length)
284 290
285INTERFACE int 291INTERFACE int
286is_vector (pointer p) 292is_vector (pointer p)
287{ 293{
288 return type (p) == T_VECTOR; 294 return type (p) == T_VECTOR;
289} 295}
290 296
291#define vecvalue(p) ((p)->object.vector.vvalue) 297#define vecvalue(p) (CELL(p)->object.vector.vvalue)
292#define veclength(p) ((p)->object.vector.length) 298#define veclength(p) (CELL(p)->object.vector.length)
293INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); 299INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
294INTERFACE pointer vector_get (pointer vec, uint32_t ielem); 300INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
295INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); 301INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
296 302
297INTERFACE int 303INTERFACE int
… …
323string_value (pointer p) 329string_value (pointer p)
324{ 330{
325 return strvalue (p); 331 return strvalue (p);
326} 332}
327 333
328#define ivalue_unchecked(p) (p)->object.ivalue 334#define ivalue_unchecked(p) CELL(p)->object.ivalue
329#define set_ivalue(p,v) (p)->object.ivalue = (v) 335#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
330 336
331#if USE_REAL 337#if USE_REAL
332#define rvalue_unchecked(p) (p)->object.rvalue 338#define rvalue_unchecked(p) CELL(p)->object.rvalue
333#define set_rvalue(p,v) (p)->object.rvalue = (v) 339#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
334#else 340#else
335#define rvalue_unchecked(p) (p)->object.ivalue 341#define rvalue_unchecked(p) CELL(p)->object.ivalue
336#define set_rvalue(p,v) (p)->object.ivalue = (v) 342#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
337#endif 343#endif
338 344
339INTERFACE long 345INTERFACE long
340charvalue (pointer p) 346charvalue (pointer p)
341{ 347{
342 return ivalue_unchecked (p); 348 return ivalue_unchecked (p);
343} 349}
344 350
351#define port(p) CELL(p)->object.port
352#define set_port(p,v) port(p) = (v)
345INTERFACE int 353INTERFACE int
346is_port (pointer p) 354is_port (pointer p)
347{ 355{
348 return type (p) == T_PORT; 356 return type (p) == T_PORT;
349} 357}
350 358
351INTERFACE int 359INTERFACE int
352is_inport (pointer p) 360is_inport (pointer p)
353{ 361{
354 return is_port (p) && p->object.port->kind & port_input; 362 return is_port (p) && port (p)->kind & port_input;
355} 363}
356 364
357INTERFACE int 365INTERFACE int
358is_outport (pointer p) 366is_outport (pointer p)
359{ 367{
360 return is_port (p) && p->object.port->kind & port_output; 368 return is_port (p) && port (p)->kind & port_output;
361} 369}
362 370
363INTERFACE int 371INTERFACE int
364is_pair (pointer p) 372is_pair (pointer p)
365{ 373{
366 return type (p) == T_PAIR; 374 return type (p) == T_PAIR;
367} 375}
368 376
369#define car(p) ((p)->object.cons.car + 0) 377#define car(p) (POINTER (CELL(p)->object.cons.car))
370#define cdr(p) ((p)->object.cons.cdr + 0) 378#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
371 379
372static pointer caar (pointer p) { return car (car (p)); } 380static pointer caar (pointer p) { return car (car (p)); }
373static pointer cadr (pointer p) { return car (cdr (p)); } 381static pointer cadr (pointer p) { return car (cdr (p)); }
374static pointer cdar (pointer p) { return cdr (car (p)); } 382static pointer cdar (pointer p) { return cdr (car (p)); }
375static pointer cddr (pointer p) { return cdr (cdr (p)); } 383static pointer cddr (pointer p) { return cdr (cdr (p)); }
… …
379static pointer cdaar (pointer p) { return cdr (car (car (p))); } 387static pointer cdaar (pointer p) { return cdr (car (car (p))); }
380 388
381INTERFACE void 389INTERFACE void
382set_car (pointer p, pointer q) 390set_car (pointer p, pointer q)
383{ 391{
384 p->object.cons.car = q; 392 CELL(p)->object.cons.car = CELL (q);
385} 393}
386 394
387INTERFACE void 395INTERFACE void
388set_cdr (pointer p, pointer q) 396set_cdr (pointer p, pointer q)
389{ 397{
390 p->object.cons.cdr = q; 398 CELL(p)->object.cons.cdr = CELL (q);
391} 399}
392 400
393INTERFACE pointer 401INTERFACE pointer
394pair_car (pointer p) 402pair_car (pointer p)
395{ 403{
… …
525 proper list: length 533 proper list: length
526 circular list: -1 534 circular list: -1
527 not even a pair: -2 535 not even a pair: -2
528 dotted list: -2 minus length before dot 536 dotted list: -2 minus length before dot
529*/ 537*/
530INTERFACE int 538ecb_hot INTERFACE int
531list_length (SCHEME_P_ pointer a) 539list_length (SCHEME_P_ pointer a)
532{ 540{
533 int i = 0; 541 int i = 0;
534 pointer slow, fast; 542 pointer slow, fast;
535 543
… …
574{ 582{
575 return list_length (SCHEME_A_ a) >= 0; 583 return list_length (SCHEME_A_ a) >= 0;
576} 584}
577 585
578#if USE_CHAR_CLASSIFIERS 586#if USE_CHAR_CLASSIFIERS
587
579ecb_inline int 588ecb_inline int
580Cisalpha (int c) 589Cisalpha (int c)
581{ 590{
582 return isascii (c) && isalpha (c); 591 return isascii (c) && isalpha (c);
583} 592}
… …
641 "gs", 650 "gs",
642 "rs", 651 "rs",
643 "us" 652 "us"
644}; 653};
645 654
646static int 655ecb_cold static int
647is_ascii_name (const char *name, int *pc) 656is_ascii_name (const char *name, int *pc)
648{ 657{
649 int i; 658 int i;
650 659
651 for (i = 0; i < 32; i++) 660 for (i = 0; i < 32; i++)
… …
670 679
671static int file_push (SCHEME_P_ const char *fname); 680static int file_push (SCHEME_P_ const char *fname);
672static void file_pop (SCHEME_P); 681static void file_pop (SCHEME_P);
673static int file_interactive (SCHEME_P); 682static int file_interactive (SCHEME_P);
674ecb_inline int is_one_of (const char *s, int c); 683ecb_inline int is_one_of (const char *s, int c);
675static int alloc_cellseg (SCHEME_P_ int n); 684static int alloc_cellseg (SCHEME_P);
676ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 685ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
677static void finalize_cell (SCHEME_P_ pointer a); 686static void finalize_cell (SCHEME_P_ pointer a);
678static int count_consecutive_cells (pointer x, int needed);
679static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 687static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
680static pointer mk_number (SCHEME_P_ const num n); 688static pointer mk_number (SCHEME_P_ const num n);
681static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 689static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
682static pointer mk_vector (SCHEME_P_ uint32_t len); 690static pointer mk_vector (SCHEME_P_ uint32_t len);
683static pointer mk_atom (SCHEME_P_ char *q); 691static pointer mk_atom (SCHEME_P_ char *q);
684static pointer mk_sharp_const (SCHEME_P_ char *name); 692static pointer mk_sharp_const (SCHEME_P_ char *name);
685 693
694static pointer mk_port (SCHEME_P_ port *p);
695
686#if USE_PORTS 696#if USE_PORTS
687static pointer mk_port (SCHEME_P_ port *p);
688static pointer port_from_filename (SCHEME_P_ const char *fn, int prop); 697static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
689static pointer port_from_file (SCHEME_P_ int, int prop); 698static pointer port_from_file (SCHEME_P_ int, int prop);
690static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 699static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
691static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop); 700static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop);
692static port *port_rep_from_file (SCHEME_P_ int, int prop); 701static port *port_rep_from_file (SCHEME_P_ int, int prop);
693static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 702static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
694static void port_close (SCHEME_P_ pointer p, int flag); 703static void port_close (SCHEME_P_ pointer p, int flag);
695#endif 704#endif
705
696static void mark (pointer a); 706static void mark (pointer a);
697static void gc (SCHEME_P_ pointer a, pointer b); 707static void gc (SCHEME_P_ pointer a, pointer b);
698static int basic_inchar (port *pt); 708static int basic_inchar (port *pt);
699static int inchar (SCHEME_P); 709static int inchar (SCHEME_P);
700static void backchar (SCHEME_P_ int c); 710static void backchar (SCHEME_P_ int c);
701static char *readstr_upto (SCHEME_P_ int skip, const char *delim); 711static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
702static pointer readstrexp (SCHEME_P_ char delim); 712static pointer readstrexp (SCHEME_P_ char delim);
703ecb_inline int skipspace (SCHEME_P); 713static int skipspace (SCHEME_P);
704static int token (SCHEME_P); 714static int token (SCHEME_P);
705static void printslashstring (SCHEME_P_ char *s, int len); 715static void printslashstring (SCHEME_P_ char *s, int len);
706static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 716static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
707static void printatom (SCHEME_P_ pointer l, int f); 717static void printatom (SCHEME_P_ pointer l, int f);
708static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 718static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
874 } 884 }
875 885
876 return ret; 886 return ret;
877} 887}
878 888
879#if USE_MATH
880
881/* Round to nearest. Round to even if midway */
882static double
883round_per_R5RS (double x)
884{
885 double fl = floor (x);
886 double ce = ceil (x);
887 double dfl = x - fl;
888 double dce = ce - x;
889
890 if (dfl > dce)
891 return ce;
892 else if (dfl < dce)
893 return fl;
894 else
895 {
896 if (fmod (fl, 2) == 0) /* I imagine this holds */
897 return fl;
898 else
899 return ce;
900 }
901}
902#endif
903
904static int 889static int
905is_zero_rvalue (RVALUE x) 890is_zero_rvalue (RVALUE x)
906{ 891{
907 return x == 0; 892 return x == 0;
908#if 0 893#if 0
… …
913#endif 898#endif
914#endif 899#endif
915} 900}
916 901
917/* allocate new cell segment */ 902/* allocate new cell segment */
918static int 903ecb_cold static int
919alloc_cellseg (SCHEME_P_ int n) 904alloc_cellseg (SCHEME_P)
920{ 905{
921 pointer newp; 906 struct cell *newp;
922 pointer last; 907 struct cell *last;
923 pointer p; 908 struct cell *p;
924 char *cp; 909 char *cp;
925 long i; 910 long i;
926 int k; 911 int k;
927 912
928 static int segsize = CELL_SEGSIZE >> 1; 913 static int segsize = CELL_SEGSIZE >> 1;
929 segsize <<= 1; 914 segsize <<= 1;
930 915
931 for (k = 0; k < n; k++)
932 {
933 if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
934 return k;
935
936 cp = malloc (segsize * sizeof (struct cell)); 916 cp = malloc (segsize * sizeof (struct cell));
937 917
938 if (!cp && USE_ERROR_CHECKING) 918 if (!cp && USE_ERROR_CHECKING)
939 return k; 919 return k;
940 920
941 i = ++SCHEME_V->last_cell_seg; 921 i = ++SCHEME_V->last_cell_seg;
942 SCHEME_V->alloc_seg[i] = cp;
943 922
944 newp = (pointer)cp; 923 newp = (struct cell *)cp;
945 SCHEME_V->cell_seg[i] = newp; 924 SCHEME_V->cell_seg[i] = newp;
946 SCHEME_V->cell_segsize[i] = segsize; 925 SCHEME_V->cell_segsize[i] = segsize;
947 SCHEME_V->fcells += segsize; 926 SCHEME_V->fcells += segsize;
948 last = newp + segsize - 1; 927 last = newp + segsize - 1;
949 928
950 for (p = newp; p <= last; p++) 929 for (p = newp; p <= last; p++)
951 { 930 {
931 pointer cp = POINTER (p);
952 set_typeflag (p, T_PAIR); 932 set_typeflag (cp, T_PAIR);
953 set_car (p, NIL); 933 set_car (cp, NIL);
954 set_cdr (p, p + 1); 934 set_cdr (cp, POINTER (p + 1));
955 } 935 }
956 936
957 set_cdr (last, SCHEME_V->free_cell); 937 set_cdr (POINTER (last), SCHEME_V->free_cell);
958 SCHEME_V->free_cell = newp; 938 SCHEME_V->free_cell = POINTER (newp);
959 }
960 939
961 return n; 940 return 1;
962} 941}
963 942
964/* get new cell. parameter a, b is marked by gc. */ 943/* get new cell. parameter a, b is marked by gc. */
965ecb_inline pointer 944ecb_inline pointer
966get_cell_x (SCHEME_P_ pointer a, pointer b) 945get_cell_x (SCHEME_P_ pointer a, pointer b)
… …
970 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 949 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
971 return S_SINK; 950 return S_SINK;
972 951
973 if (SCHEME_V->free_cell == NIL) 952 if (SCHEME_V->free_cell == NIL)
974 { 953 {
975 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1; 954 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
976 955
977 gc (SCHEME_A_ a, b); 956 gc (SCHEME_A_ a, b);
978 957
979 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 958 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
980 { 959 {
981 /* if only a few recovered, get more to avoid fruitless gc's */ 960 /* if only a few recovered, get more to avoid fruitless gc's */
982 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 961 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
983 { 962 {
984#if USE_ERROR_CHECKING 963#if USE_ERROR_CHECKING
985 SCHEME_V->no_memory = 1; 964 SCHEME_V->no_memory = 1;
986 return S_SINK; 965 return S_SINK;
987#endif 966#endif
… …
999 } 978 }
1000} 979}
1001 980
1002/* To retain recent allocs before interpreter knows about them - 981/* To retain recent allocs before interpreter knows about them -
1003 Tehom */ 982 Tehom */
1004 983ecb_hot static void
1005static void
1006push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 984push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1007{ 985{
1008 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 986 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1009 987
1010 set_typeflag (holder, T_PAIR); 988 set_typeflag (holder, T_PAIR);
… …
1012 set_car (holder, recent); 990 set_car (holder, recent);
1013 set_cdr (holder, car (S_SINK)); 991 set_cdr (holder, car (S_SINK));
1014 set_car (S_SINK, holder); 992 set_car (S_SINK, holder);
1015} 993}
1016 994
1017static pointer 995ecb_hot static pointer
1018get_cell (SCHEME_P_ pointer a, pointer b) 996get_cell (SCHEME_P_ pointer a, pointer b)
1019{ 997{
1020 pointer cell = get_cell_x (SCHEME_A_ a, b); 998 pointer cell = get_cell_x (SCHEME_A_ a, b);
1021 999
1022 /* For right now, include "a" and "b" in "cell" so that gc doesn't 1000 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1040 return S_SINK; 1018 return S_SINK;
1041 1019
1042 /* Record it as a vector so that gc understands it. */ 1020 /* Record it as a vector so that gc understands it. */
1043 set_typeflag (v, T_VECTOR | T_ATOM); 1021 set_typeflag (v, T_VECTOR | T_ATOM);
1044 1022
1045 v->object.vector.vvalue = e; 1023 CELL(v)->object.vector.vvalue = e;
1046 v->object.vector.length = len; 1024 CELL(v)->object.vector.length = len;
1047 fill_vector (v, 0, init); 1025 fill_vector (v, 0, init);
1048 push_recent_alloc (SCHEME_A_ v, NIL); 1026 push_recent_alloc (SCHEME_A_ v, NIL);
1049 1027
1050 return v; 1028 return v;
1051} 1029}
… …
1060static void 1038static void
1061check_cell_alloced (pointer p, int expect_alloced) 1039check_cell_alloced (pointer p, int expect_alloced)
1062{ 1040{
1063 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ 1041 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1064 if (typeflag (p) & !expect_alloced) 1042 if (typeflag (p) & !expect_alloced)
1065 xwrstr ("Cell is already allocated!\n"); 1043 putstr (SCHEME_A_ "Cell is already allocated!\n");
1066 1044
1067 if (!(typeflag (p)) & expect_alloced) 1045 if (!(typeflag (p)) & expect_alloced)
1068 xwrstr ("Cell is not allocated!\n"); 1046 putstr (SCHEME_A_ "Cell is not allocated!\n");
1069} 1047}
1070 1048
1071static void 1049static void
1072check_range_alloced (pointer p, int n, int expect_alloced) 1050check_range_alloced (pointer p, int n, int expect_alloced)
1073{ 1051{
… …
1079#endif 1057#endif
1080 1058
1081/* Medium level cell allocation */ 1059/* Medium level cell allocation */
1082 1060
1083/* get new cons cell */ 1061/* get new cons cell */
1084pointer 1062ecb_hot static pointer
1085xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1063xcons (SCHEME_P_ pointer a, pointer b)
1086{ 1064{
1087 pointer x = get_cell (SCHEME_A_ a, b); 1065 pointer x = get_cell (SCHEME_A_ a, b);
1088 1066
1089 set_typeflag (x, T_PAIR); 1067 set_typeflag (x, T_PAIR);
1090
1091 if (immutable)
1092 setimmutable (x);
1093 1068
1094 set_car (x, a); 1069 set_car (x, a);
1095 set_cdr (x, b); 1070 set_cdr (x, b);
1096 1071
1097 return x; 1072 return x;
1098} 1073}
1099 1074
1100static pointer 1075ecb_hot static pointer
1076ximmutable_cons (SCHEME_P_ pointer a, pointer b)
1077{
1078 pointer x = xcons (SCHEME_A_ a, b);
1079 setimmutable (x);
1080 return x;
1081}
1082
1083#define cons(a,b) xcons (SCHEME_A_ a, b)
1084#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1085
1086ecb_cold static pointer
1101generate_symbol (SCHEME_P_ const char *name) 1087generate_symbol (SCHEME_P_ const char *name)
1102{ 1088{
1103 pointer x = mk_string (SCHEME_A_ name); 1089 pointer x = mk_string (SCHEME_A_ name);
1104 setimmutable (x); 1090 setimmutable (x);
1105 set_typeflag (x, T_SYMBOL | T_ATOM); 1091 set_typeflag (x, T_SYMBOL | T_ATOM);
… …
1111#ifndef USE_OBJECT_LIST 1097#ifndef USE_OBJECT_LIST
1112 1098
1113static int 1099static int
1114hash_fn (const char *key, int table_size) 1100hash_fn (const char *key, int table_size)
1115{ 1101{
1116 const unsigned char *p = key; 1102 const unsigned char *p = (unsigned char *)key;
1117 uint32_t hash = 2166136261; 1103 uint32_t hash = 2166136261U;
1118 1104
1119 while (*p) 1105 while (*p)
1120 hash = (hash ^ *p++) * 16777619; 1106 hash = (hash ^ *p++) * 16777619;
1121 1107
1122 return hash % table_size; 1108 return hash % table_size;
1123} 1109}
1124 1110
1125static pointer 1111ecb_cold static pointer
1126oblist_initial_value (SCHEME_P) 1112oblist_initial_value (SCHEME_P)
1127{ 1113{
1128 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1114 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1129} 1115}
1130 1116
1131/* returns the new symbol */ 1117/* returns the new symbol */
1132static pointer 1118ecb_cold static pointer
1133oblist_add_by_name (SCHEME_P_ const char *name) 1119oblist_add_by_name (SCHEME_P_ const char *name)
1134{ 1120{
1135 pointer x = generate_symbol (SCHEME_A_ name); 1121 pointer x = generate_symbol (SCHEME_A_ name);
1136 int location = hash_fn (name, veclength (SCHEME_V->oblist)); 1122 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1137 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); 1123 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1138 return x; 1124 return x;
1139} 1125}
1140 1126
1141ecb_inline pointer 1127ecb_cold static pointer
1142oblist_find_by_name (SCHEME_P_ const char *name) 1128oblist_find_by_name (SCHEME_P_ const char *name)
1143{ 1129{
1144 int location; 1130 int location;
1145 pointer x; 1131 pointer x;
1146 char *s; 1132 char *s;
… …
1157 } 1143 }
1158 1144
1159 return NIL; 1145 return NIL;
1160} 1146}
1161 1147
1162static pointer 1148ecb_cold static pointer
1163oblist_all_symbols (SCHEME_P) 1149oblist_all_symbols (SCHEME_P)
1164{ 1150{
1165 int i; 1151 int i;
1166 pointer x; 1152 pointer x;
1167 pointer ob_list = NIL; 1153 pointer ob_list = NIL;
… …
1173 return ob_list; 1159 return ob_list;
1174} 1160}
1175 1161
1176#else 1162#else
1177 1163
1178static pointer 1164ecb_cold static pointer
1179oblist_initial_value (SCHEME_P) 1165oblist_initial_value (SCHEME_P)
1180{ 1166{
1181 return NIL; 1167 return NIL;
1182} 1168}
1183 1169
1184ecb_inline pointer 1170ecb_cold static pointer
1185oblist_find_by_name (SCHEME_P_ const char *name) 1171oblist_find_by_name (SCHEME_P_ const char *name)
1186{ 1172{
1187 pointer x; 1173 pointer x;
1188 char *s; 1174 char *s;
1189 1175
… …
1198 1184
1199 return NIL; 1185 return NIL;
1200} 1186}
1201 1187
1202/* returns the new symbol */ 1188/* returns the new symbol */
1203static pointer 1189ecb_cold static pointer
1204oblist_add_by_name (SCHEME_P_ const char *name) 1190oblist_add_by_name (SCHEME_P_ const char *name)
1205{ 1191{
1206 pointer x = generate_symbol (SCHEME_A_ name); 1192 pointer x = generate_symbol (SCHEME_A_ name);
1207 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1193 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1208 return x; 1194 return x;
1209} 1195}
1210 1196
1211static pointer 1197ecb_cold static pointer
1212oblist_all_symbols (SCHEME_P) 1198oblist_all_symbols (SCHEME_P)
1213{ 1199{
1214 return SCHEME_V->oblist; 1200 return SCHEME_V->oblist;
1215} 1201}
1216 1202
1217#endif 1203#endif
1218 1204
1219#if USE_PORTS
1220static pointer 1205ecb_cold static pointer
1221mk_port (SCHEME_P_ port *p) 1206mk_port (SCHEME_P_ port *p)
1222{ 1207{
1223 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1208 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1224 1209
1225 set_typeflag (x, T_PORT | T_ATOM); 1210 set_typeflag (x, T_PORT | T_ATOM);
1226 x->object.port = p; 1211 set_port (x, p);
1227 1212
1228 return x; 1213 return x;
1229} 1214}
1230#endif
1231 1215
1232pointer 1216ecb_cold pointer
1233mk_foreign_func (SCHEME_P_ foreign_func f) 1217mk_foreign_func (SCHEME_P_ foreign_func f)
1234{ 1218{
1235 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1219 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1236 1220
1237 set_typeflag (x, T_FOREIGN | T_ATOM); 1221 set_typeflag (x, T_FOREIGN | T_ATOM);
1238 x->object.ff = f; 1222 CELL(x)->object.ff = f;
1239 1223
1240 return x; 1224 return x;
1241} 1225}
1242 1226
1243INTERFACE pointer 1227INTERFACE pointer
… …
1402 x = oblist_add_by_name (SCHEME_A_ name); 1386 x = oblist_add_by_name (SCHEME_A_ name);
1403 1387
1404 return x; 1388 return x;
1405} 1389}
1406 1390
1407INTERFACE pointer 1391ecb_cold INTERFACE pointer
1408gensym (SCHEME_P) 1392gensym (SCHEME_P)
1409{ 1393{
1410 pointer x; 1394 pointer x;
1411 char name[40] = "gensym-"; 1395 char name[40] = "gensym-";
1412 xnum (name + 7, ++SCHEME_V->gensym_cnt); 1396 xnum (name + 7, ++SCHEME_V->gensym_cnt);
… …
1419{ 1403{
1420 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; 1404 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1421} 1405}
1422 1406
1423/* make symbol or number atom from string */ 1407/* make symbol or number atom from string */
1424static pointer 1408ecb_cold static pointer
1425mk_atom (SCHEME_P_ char *q) 1409mk_atom (SCHEME_P_ char *q)
1426{ 1410{
1427 char c, *p; 1411 char c, *p;
1428 int has_dec_point = 0; 1412 int has_dec_point = 0;
1429 int has_fp_exp = 0; 1413 int has_fp_exp = 0;
… …
1500 1484
1501 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1485 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1502} 1486}
1503 1487
1504/* make constant */ 1488/* make constant */
1505static pointer 1489ecb_cold static pointer
1506mk_sharp_const (SCHEME_P_ char *name) 1490mk_sharp_const (SCHEME_P_ char *name)
1507{ 1491{
1508 if (!strcmp (name, "t")) 1492 if (!strcmp (name, "t"))
1509 return S_T; 1493 return S_T;
1510 else if (!strcmp (name, "f")) 1494 else if (!strcmp (name, "f"))
1511 return S_F; 1495 return S_F;
1512 else if (*name == '\\') /* #\w (character) */ 1496 else if (*name == '\\') /* #\w (character) */
1513 { 1497 {
1514 int c; 1498 int c;
1515 1499
1500 // TODO: optimise
1516 if (stricmp (name + 1, "space") == 0) 1501 if (stricmp (name + 1, "space") == 0)
1517 c = ' '; 1502 c = ' ';
1518 else if (stricmp (name + 1, "newline") == 0) 1503 else if (stricmp (name + 1, "newline") == 0)
1519 c = '\n'; 1504 c = '\n';
1520 else if (stricmp (name + 1, "return") == 0) 1505 else if (stricmp (name + 1, "return") == 0)
1521 c = '\r'; 1506 c = '\r';
1522 else if (stricmp (name + 1, "tab") == 0) 1507 else if (stricmp (name + 1, "tab") == 0)
1523 c = '\t'; 1508 c = '\t';
1509 else if (stricmp (name + 1, "alarm") == 0)
1510 c = 0x07;
1511 else if (stricmp (name + 1, "backspace") == 0)
1512 c = 0x08;
1513 else if (stricmp (name + 1, "escape") == 0)
1514 c = 0x1b;
1515 else if (stricmp (name + 1, "delete") == 0)
1516 c = 0x7f;
1517 else if (stricmp (name + 1, "null") == 0)
1518 c = 0;
1524 else if (name[1] == 'x' && name[2] != 0) 1519 else if (name[1] == 'x' && name[2] != 0)
1525 { 1520 {
1526 long c1 = strtol (name + 2, 0, 16); 1521 long c1 = strtol (name + 2, 0, 16);
1527 1522
1528 if (0 <= c1 && c1 <= UCHAR_MAX) 1523 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1553 return NIL; 1548 return NIL;
1554 } 1549 }
1555} 1550}
1556 1551
1557/* ========== garbage collector ========== */ 1552/* ========== garbage collector ========== */
1553
1554static void
1555finalize_cell (SCHEME_P_ pointer a)
1556{
1557 /* TODO, fast bitmap check? */
1558 if (is_string (a) || is_symbol (a))
1559 free (strvalue (a));
1560 else if (is_vector (a))
1561 free (vecvalue (a));
1562#if USE_PORTS
1563 else if (is_port (a))
1564 {
1565 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1566 port_close (SCHEME_A_ a, port_input | port_output);
1567
1568 free (port (a));
1569 }
1570#endif
1571}
1558 1572
1559/*-- 1573/*--
1560 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1574 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1561 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1575 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1562 * for marking. 1576 * for marking.
1563 * 1577 *
1564 * The exception is vectors - vectors are currently marked recursively, 1578 * The exception is vectors - vectors are currently marked recursively,
1565 * which is inherited form tinyscheme and could be fixed by having another 1579 * which is inherited form tinyscheme and could be fixed by having another
1566 * word of context in the vector 1580 * word of context in the vector
1567 */ 1581 */
1568static void 1582ecb_hot static void
1569mark (pointer a) 1583mark (pointer a)
1570{ 1584{
1571 pointer t, q, p; 1585 pointer t, q, p;
1572 1586
1573 t = 0; 1587 t = 0;
… …
1630 p = q; 1644 p = q;
1631 goto E6; 1645 goto E6;
1632 } 1646 }
1633} 1647}
1634 1648
1649ecb_hot static void
1650gc_free (SCHEME_P)
1651{
1652 int i;
1653 uint32_t total = 0;
1654
1655 /* Here we scan the cells to build the free-list. */
1656 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1657 {
1658 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1659 struct cell *p;
1660 total += SCHEME_V->cell_segsize [i];
1661
1662 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1663 {
1664 pointer c = POINTER (p);
1665
1666 if (is_mark (c))
1667 clrmark (c);
1668 else
1669 {
1670 /* reclaim cell */
1671 if (typeflag (c) != T_PAIR)
1672 {
1673 finalize_cell (SCHEME_A_ c);
1674 set_typeflag (c, T_PAIR);
1675 set_car (c, NIL);
1676 }
1677
1678 ++SCHEME_V->fcells;
1679 set_cdr (c, SCHEME_V->free_cell);
1680 SCHEME_V->free_cell = c;
1681 }
1682 }
1683 }
1684
1685 if (SCHEME_V->gc_verbose)
1686 {
1687 putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n");
1688 }
1689}
1690
1635/* garbage collection. parameter a, b is marked. */ 1691/* garbage collection. parameter a, b is marked. */
1636static void 1692ecb_cold static void
1637gc (SCHEME_P_ pointer a, pointer b) 1693gc (SCHEME_P_ pointer a, pointer b)
1638{ 1694{
1639 pointer p;
1640 int i; 1695 int i;
1641 1696
1642 if (SCHEME_V->gc_verbose) 1697 if (SCHEME_V->gc_verbose)
1643 putstr (SCHEME_A_ "gc..."); 1698 putstr (SCHEME_A_ "gc...");
1644 1699
… …
1677 clrmark (NIL); 1732 clrmark (NIL);
1678 SCHEME_V->fcells = 0; 1733 SCHEME_V->fcells = 0;
1679 SCHEME_V->free_cell = NIL; 1734 SCHEME_V->free_cell = NIL;
1680 1735
1681 if (SCHEME_V->gc_verbose) 1736 if (SCHEME_V->gc_verbose)
1682 xwrstr ("freeing..."); 1737 putstr (SCHEME_A_ "freeing...");
1683 1738
1684 uint32_t total = 0; 1739 gc_free (SCHEME_A);
1685
1686 /* Here we scan the cells to build the free-list. */
1687 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1688 {
1689 pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1690 total += SCHEME_V->cell_segsize [i];
1691
1692 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1693 {
1694 if (is_mark (p))
1695 clrmark (p);
1696 else
1697 {
1698 /* reclaim cell */
1699 if (typeflag (p) != T_PAIR)
1700 {
1701 finalize_cell (SCHEME_A_ p);
1702 set_typeflag (p, T_PAIR);
1703 set_car (p, NIL);
1704 }
1705
1706 ++SCHEME_V->fcells;
1707 set_cdr (p, SCHEME_V->free_cell);
1708 SCHEME_V->free_cell = p;
1709 }
1710 }
1711 }
1712
1713 if (SCHEME_V->gc_verbose)
1714 {
1715 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n");
1716 }
1717}
1718
1719static void
1720finalize_cell (SCHEME_P_ pointer a)
1721{
1722 /* TODO, fast bitmap check? */
1723 if (is_string (a) || is_symbol (a))
1724 free (strvalue (a));
1725 else if (is_vector (a))
1726 free (vecvalue (a));
1727#if USE_PORTS
1728 else if (is_port (a))
1729 {
1730 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1731 port_close (SCHEME_A_ a, port_input | port_output);
1732
1733 free (a->object.port);
1734 }
1735#endif
1736} 1740}
1737 1741
1738/* ========== Routines for Reading ========== */ 1742/* ========== Routines for Reading ========== */
1739 1743
1740static int 1744ecb_cold static int
1741file_push (SCHEME_P_ const char *fname) 1745file_push (SCHEME_P_ const char *fname)
1742{ 1746{
1743#if USE_PORTS
1744 int fin; 1747 int fin;
1745 1748
1746 if (SCHEME_V->file_i == MAXFIL - 1) 1749 if (SCHEME_V->file_i == MAXFIL - 1)
1747 return 0; 1750 return 0;
1748 1751
… …
1754 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1757 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1755 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1758 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1756 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; 1759 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1757 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; 1760 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1758 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1761 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1759 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1762 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1760 1763
1761#if SHOW_ERROR_LINE 1764#if SHOW_ERROR_LINE
1762 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1765 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1763 1766
1764 if (fname) 1767 if (fname)
1765 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0); 1768 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1766#endif 1769#endif
1767 } 1770 }
1768 1771
1769 return fin >= 0; 1772 return fin >= 0;
1770
1771#else
1772 return 1;
1773#endif
1774} 1773}
1775 1774
1776static void 1775ecb_cold static void
1777file_pop (SCHEME_P) 1776file_pop (SCHEME_P)
1778{ 1777{
1779 if (SCHEME_V->file_i != 0) 1778 if (SCHEME_V->file_i != 0)
1780 { 1779 {
1781 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1780 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1782#if USE_PORTS 1781#if USE_PORTS
1783 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1782 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1784#endif 1783#endif
1785 SCHEME_V->file_i--; 1784 SCHEME_V->file_i--;
1786 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1785 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1787 } 1786 }
1788} 1787}
1789 1788
1790static int 1789ecb_cold static int
1791file_interactive (SCHEME_P) 1790file_interactive (SCHEME_P)
1792{ 1791{
1793#if USE_PORTS 1792#if USE_PORTS
1794 return SCHEME_V->file_i == 0 1793 return SCHEME_V->file_i == 0
1795 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1794 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1796 && (SCHEME_V->inport->object.port->kind & port_file); 1795 && (port (SCHEME_V->inport)->kind & port_file);
1797#else 1796#else
1798 return 0; 1797 return 0;
1799#endif 1798#endif
1800} 1799}
1801 1800
1802#if USE_PORTS 1801#if USE_PORTS
1803static port * 1802ecb_cold static port *
1804port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1803port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1805{ 1804{
1806 int fd; 1805 int fd;
1807 int flags; 1806 int flags;
1808 char *rw; 1807 char *rw;
… …
1831# endif 1830# endif
1832 1831
1833 return pt; 1832 return pt;
1834} 1833}
1835 1834
1836static pointer 1835ecb_cold static pointer
1837port_from_filename (SCHEME_P_ const char *fn, int prop) 1836port_from_filename (SCHEME_P_ const char *fn, int prop)
1838{ 1837{
1839 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1838 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1840 1839
1841 if (!pt && USE_ERROR_CHECKING) 1840 if (!pt && USE_ERROR_CHECKING)
1842 return NIL; 1841 return NIL;
1843 1842
1844 return mk_port (SCHEME_A_ pt); 1843 return mk_port (SCHEME_A_ pt);
1845} 1844}
1846 1845
1847static port * 1846ecb_cold static port *
1848port_rep_from_file (SCHEME_P_ int f, int prop) 1847port_rep_from_file (SCHEME_P_ int f, int prop)
1849{ 1848{
1850 port *pt = malloc (sizeof *pt); 1849 port *pt = malloc (sizeof *pt);
1851 1850
1852 if (!pt && USE_ERROR_CHECKING) 1851 if (!pt && USE_ERROR_CHECKING)
… …
1857 pt->rep.stdio.file = f; 1856 pt->rep.stdio.file = f;
1858 pt->rep.stdio.closeit = 0; 1857 pt->rep.stdio.closeit = 0;
1859 return pt; 1858 return pt;
1860} 1859}
1861 1860
1862static pointer 1861ecb_cold static pointer
1863port_from_file (SCHEME_P_ int f, int prop) 1862port_from_file (SCHEME_P_ int f, int prop)
1864{ 1863{
1865 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1864 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1866 1865
1867 if (!pt && USE_ERROR_CHECKING) 1866 if (!pt && USE_ERROR_CHECKING)
1868 return NIL; 1867 return NIL;
1869 1868
1870 return mk_port (SCHEME_A_ pt); 1869 return mk_port (SCHEME_A_ pt);
1871} 1870}
1872 1871
1873static port * 1872ecb_cold static port *
1874port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1873port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1875{ 1874{
1876 port *pt = malloc (sizeof (port)); 1875 port *pt = malloc (sizeof (port));
1877 1876
1878 if (!pt && USE_ERROR_CHECKING) 1877 if (!pt && USE_ERROR_CHECKING)
… …
1884 pt->rep.string.curr = start; 1883 pt->rep.string.curr = start;
1885 pt->rep.string.past_the_end = past_the_end; 1884 pt->rep.string.past_the_end = past_the_end;
1886 return pt; 1885 return pt;
1887} 1886}
1888 1887
1889static pointer 1888ecb_cold static pointer
1890port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1889port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1891{ 1890{
1892 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1891 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1893 1892
1894 if (!pt && USE_ERROR_CHECKING) 1893 if (!pt && USE_ERROR_CHECKING)
… …
1897 return mk_port (SCHEME_A_ pt); 1896 return mk_port (SCHEME_A_ pt);
1898} 1897}
1899 1898
1900# define BLOCK_SIZE 256 1899# define BLOCK_SIZE 256
1901 1900
1902static port * 1901ecb_cold static port *
1903port_rep_from_scratch (SCHEME_P) 1902port_rep_from_scratch (SCHEME_P)
1904{ 1903{
1905 char *start; 1904 char *start;
1906 port *pt = malloc (sizeof (port)); 1905 port *pt = malloc (sizeof (port));
1907 1906
… …
1921 pt->rep.string.curr = start; 1920 pt->rep.string.curr = start;
1922 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1921 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1923 return pt; 1922 return pt;
1924} 1923}
1925 1924
1926static pointer 1925ecb_cold static pointer
1927port_from_scratch (SCHEME_P) 1926port_from_scratch (SCHEME_P)
1928{ 1927{
1929 port *pt = port_rep_from_scratch (SCHEME_A); 1928 port *pt = port_rep_from_scratch (SCHEME_A);
1930 1929
1931 if (!pt && USE_ERROR_CHECKING) 1930 if (!pt && USE_ERROR_CHECKING)
1932 return NIL; 1931 return NIL;
1933 1932
1934 return mk_port (SCHEME_A_ pt); 1933 return mk_port (SCHEME_A_ pt);
1935} 1934}
1936 1935
1937static void 1936ecb_cold static void
1938port_close (SCHEME_P_ pointer p, int flag) 1937port_close (SCHEME_P_ pointer p, int flag)
1939{ 1938{
1940 port *pt = p->object.port; 1939 port *pt = port (p);
1941 1940
1942 pt->kind &= ~flag; 1941 pt->kind &= ~flag;
1943 1942
1944 if ((pt->kind & (port_input | port_output)) == 0) 1943 if ((pt->kind & (port_input | port_output)) == 0)
1945 { 1944 {
… …
1962 } 1961 }
1963} 1962}
1964#endif 1963#endif
1965 1964
1966/* get new character from input file */ 1965/* get new character from input file */
1967static int 1966ecb_cold static int
1968inchar (SCHEME_P) 1967inchar (SCHEME_P)
1969{ 1968{
1970 int c; 1969 int c;
1971 port *pt; 1970 port *pt = port (SCHEME_V->inport);
1972
1973 pt = SCHEME_V->inport->object.port;
1974 1971
1975 if (pt->kind & port_saw_EOF) 1972 if (pt->kind & port_saw_EOF)
1976 return EOF; 1973 return EOF;
1977 1974
1978 c = basic_inchar (pt); 1975 c = basic_inchar (pt);
… …
1988 } 1985 }
1989 1986
1990 return c; 1987 return c;
1991} 1988}
1992 1989
1993static int ungot = -1; 1990ecb_cold static int
1994
1995static int
1996basic_inchar (port *pt) 1991basic_inchar (port *pt)
1997{ 1992{
1998#if USE_PORTS
1999 if (pt->unget != -1) 1993 if (pt->unget != -1)
2000 { 1994 {
2001 int r = pt->unget; 1995 int r = pt->unget;
2002 pt->unget = -1; 1996 pt->unget = -1;
2003 return r; 1997 return r;
2004 } 1998 }
2005 1999
2000#if USE_PORTS
2006 if (pt->kind & port_file) 2001 if (pt->kind & port_file)
2007 { 2002 {
2008 char c; 2003 char c;
2009 2004
2010 if (!read (pt->rep.stdio.file, &c, 1)) 2005 if (!read (pt->rep.stdio.file, &c, 1))
… …
2018 return EOF; 2013 return EOF;
2019 else 2014 else
2020 return *pt->rep.string.curr++; 2015 return *pt->rep.string.curr++;
2021 } 2016 }
2022#else 2017#else
2023 if (ungot == -1)
2024 {
2025 char c; 2018 char c;
2026 if (!read (0, &c, 1)) 2019
2020 if (!read (pt->rep.stdio.file, &c, 1))
2027 return EOF; 2021 return EOF;
2028 2022
2029 ungot = c;
2030 }
2031
2032 {
2033 int r = ungot;
2034 ungot = -1;
2035 return r; 2023 return c;
2036 }
2037#endif 2024#endif
2038} 2025}
2039 2026
2040/* back character to input buffer */ 2027/* back character to input buffer */
2041static void 2028ecb_cold static void
2042backchar (SCHEME_P_ int c) 2029backchar (SCHEME_P_ int c)
2043{ 2030{
2044#if USE_PORTS 2031 port *pt = port (SCHEME_V->inport);
2045 port *pt;
2046 2032
2047 if (c == EOF) 2033 if (c == EOF)
2048 return; 2034 return;
2049 2035
2050 pt = SCHEME_V->inport->object.port;
2051 pt->unget = c; 2036 pt->unget = c;
2052#else
2053 if (c == EOF)
2054 return;
2055
2056 ungot = c;
2057#endif
2058} 2037}
2059 2038
2060#if USE_PORTS 2039#if USE_PORTS
2061static int 2040ecb_cold static int
2062realloc_port_string (SCHEME_P_ port *p) 2041realloc_port_string (SCHEME_P_ port *p)
2063{ 2042{
2064 char *start = p->rep.string.start; 2043 char *start = p->rep.string.start;
2065 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2044 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2066 char *str = malloc (new_size); 2045 char *str = malloc (new_size);
… …
2079 else 2058 else
2080 return 0; 2059 return 0;
2081} 2060}
2082#endif 2061#endif
2083 2062
2084INTERFACE void 2063ecb_cold static void
2085putstr (SCHEME_P_ const char *s) 2064putchars (SCHEME_P_ const char *s, int len)
2086{ 2065{
2066 port *pt = port (SCHEME_V->outport);
2067
2087#if USE_PORTS 2068#if USE_PORTS
2088 port *pt = SCHEME_V->outport->object.port;
2089
2090 if (pt->kind & port_file)
2091 write (pt->rep.stdio.file, s, strlen (s));
2092 else
2093 for (; *s; s++)
2094 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2095 *pt->rep.string.curr++ = *s;
2096 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2097 *pt->rep.string.curr++ = *s;
2098
2099#else
2100 xwrstr (s);
2101#endif
2102}
2103
2104static void
2105putchars (SCHEME_P_ const char *s, int len)
2106{
2107#if USE_PORTS
2108 port *pt = SCHEME_V->outport->object.port;
2109
2110 if (pt->kind & port_file) 2069 if (pt->kind & port_file)
2111 write (pt->rep.stdio.file, s, len); 2070 write (pt->rep.stdio.file, s, len);
2112 else 2071 else
2113 { 2072 {
2114 for (; len; len--) 2073 for (; len; len--)
… …
2119 *pt->rep.string.curr++ = *s++; 2078 *pt->rep.string.curr++ = *s++;
2120 } 2079 }
2121 } 2080 }
2122 2081
2123#else 2082#else
2124 write (1, s, len); 2083 write (1, s, len); // output not initialised
2125#endif 2084#endif
2085}
2086
2087INTERFACE void
2088putstr (SCHEME_P_ const char *s)
2089{
2090 putchars (SCHEME_A_ s, strlen (s));
2126} 2091}
2127 2092
2128INTERFACE void 2093INTERFACE void
2129putcharacter (SCHEME_P_ int c) 2094putcharacter (SCHEME_P_ int c)
2130{ 2095{
2131#if USE_PORTS
2132 port *pt = SCHEME_V->outport->object.port;
2133
2134 if (pt->kind & port_file)
2135 {
2136 char cc = c;
2137 write (pt->rep.stdio.file, &cc, 1);
2138 }
2139 else
2140 {
2141 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2142 *pt->rep.string.curr++ = c;
2143 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2144 *pt->rep.string.curr++ = c;
2145 }
2146
2147#else
2148 char cc = c; 2096 char cc = c;
2149 write (1, &c, 1); 2097
2150#endif 2098 putchars (SCHEME_A_ &cc, 1);
2151} 2099}
2152 2100
2153/* read characters up to delimiter, but cater to character constants */ 2101/* read characters up to delimiter, but cater to character constants */
2154static char * 2102ecb_cold static char *
2155readstr_upto (SCHEME_P_ int skip, const char *delim) 2103readstr_upto (SCHEME_P_ int skip, const char *delim)
2156{ 2104{
2157 char *p = SCHEME_V->strbuff + skip; 2105 char *p = SCHEME_V->strbuff + skip;
2158 2106
2159 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2107 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
… …
2168 2116
2169 return SCHEME_V->strbuff; 2117 return SCHEME_V->strbuff;
2170} 2118}
2171 2119
2172/* read string expression "xxx...xxx" */ 2120/* read string expression "xxx...xxx" */
2173static pointer 2121ecb_cold static pointer
2174readstrexp (SCHEME_P_ char delim) 2122readstrexp (SCHEME_P_ char delim)
2175{ 2123{
2176 char *p = SCHEME_V->strbuff; 2124 char *p = SCHEME_V->strbuff;
2177 int c; 2125 int c;
2178 int c1 = 0; 2126 int c1 = 0;
… …
2211 case '7': 2159 case '7':
2212 state = st_oct1; 2160 state = st_oct1;
2213 c1 = c - '0'; 2161 c1 = c - '0';
2214 break; 2162 break;
2215 2163
2164 case 'a': *p++ = '\a'; state = st_ok; break;
2165 case 'n': *p++ = '\n'; state = st_ok; break;
2166 case 'r': *p++ = '\r'; state = st_ok; break;
2167 case 't': *p++ = '\t'; state = st_ok; break;
2168
2169 // this overshoots the minimum requirements of r7rs
2170 case ' ':
2171 case '\t':
2172 case '\r':
2173 case '\n':
2174 skipspace (SCHEME_A);
2175 state = st_ok;
2176 break;
2177
2178 //TODO: x should end in ;, not two-digit hex
2216 case 'x': 2179 case 'x':
2217 case 'X': 2180 case 'X':
2218 state = st_x1; 2181 state = st_x1;
2219 c1 = 0; 2182 c1 = 0;
2220 break;
2221
2222 case 'n':
2223 *p++ = '\n';
2224 state = st_ok;
2225 break;
2226
2227 case 't':
2228 *p++ = '\t';
2229 state = st_ok;
2230 break;
2231
2232 case 'r':
2233 *p++ = '\r';
2234 state = st_ok;
2235 break; 2183 break;
2236 2184
2237 default: 2185 default:
2238 *p++ = c; 2186 *p++ = c;
2239 state = st_ok; 2187 state = st_ok;
… …
2291 } 2239 }
2292 } 2240 }
2293} 2241}
2294 2242
2295/* check c is in chars */ 2243/* check c is in chars */
2296ecb_inline int 2244ecb_cold int
2297is_one_of (const char *s, int c) 2245is_one_of (const char *s, int c)
2298{ 2246{
2299 return c == EOF || !!strchr (s, c); 2247 return c == EOF || !!strchr (s, c);
2300} 2248}
2301 2249
2302/* skip white characters */ 2250/* skip white characters */
2303ecb_inline int 2251ecb_cold int
2304skipspace (SCHEME_P) 2252skipspace (SCHEME_P)
2305{ 2253{
2306 int c, curr_line = 0; 2254 int c, curr_line = 0;
2307 2255
2308 do 2256 do
… …
2328 backchar (SCHEME_A_ c); 2276 backchar (SCHEME_A_ c);
2329 return 1; 2277 return 1;
2330} 2278}
2331 2279
2332/* get token */ 2280/* get token */
2333static int 2281ecb_cold static int
2334token (SCHEME_P) 2282token (SCHEME_P)
2335{ 2283{
2336 int c = skipspace (SCHEME_A); 2284 int c = skipspace (SCHEME_A);
2337 2285
2338 if (c == EOF) 2286 if (c == EOF)
… …
2436} 2384}
2437 2385
2438/* ========== Routines for Printing ========== */ 2386/* ========== Routines for Printing ========== */
2439#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2387#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2440 2388
2441static void 2389ecb_cold static void
2442printslashstring (SCHEME_P_ char *p, int len) 2390printslashstring (SCHEME_P_ char *p, int len)
2443{ 2391{
2444 int i; 2392 int i;
2445 unsigned char *s = (unsigned char *) p; 2393 unsigned char *s = (unsigned char *) p;
2446 2394
… …
2502 2450
2503 putcharacter (SCHEME_A_ '"'); 2451 putcharacter (SCHEME_A_ '"');
2504} 2452}
2505 2453
2506/* print atoms */ 2454/* print atoms */
2507static void 2455ecb_cold static void
2508printatom (SCHEME_P_ pointer l, int f) 2456printatom (SCHEME_P_ pointer l, int f)
2509{ 2457{
2510 char *p; 2458 char *p;
2511 int len; 2459 int len;
2512 2460
2513 atom2str (SCHEME_A_ l, f, &p, &len); 2461 atom2str (SCHEME_A_ l, f, &p, &len);
2514 putchars (SCHEME_A_ p, len); 2462 putchars (SCHEME_A_ p, len);
2515} 2463}
2516 2464
2517/* Uses internal buffer unless string pointer is already available */ 2465/* Uses internal buffer unless string pointer is already available */
2518static void 2466ecb_cold static void
2519atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2467atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2520{ 2468{
2521 char *p; 2469 char *p;
2522 2470
2523 if (l == NIL) 2471 if (l == NIL)
… …
2730 return car (d); 2678 return car (d);
2731 2679
2732 p = cons (car (d), cdr (d)); 2680 p = cons (car (d), cdr (d));
2733 q = p; 2681 q = p;
2734 2682
2735 while (cdr (cdr (p)) != NIL) 2683 while (cddr (p) != NIL)
2736 { 2684 {
2737 d = cons (car (p), cdr (p)); 2685 d = cons (car (p), cdr (p));
2738 2686
2739 if (cdr (cdr (p)) != NIL) 2687 if (cddr (p) != NIL)
2740 p = cdr (d); 2688 p = cdr (d);
2741 } 2689 }
2742 2690
2743 set_cdr (p, car (cdr (p))); 2691 set_cdr (p, cadr (p));
2744 return q; 2692 return q;
2745} 2693}
2746 2694
2747/* reverse list -- produce new list */ 2695/* reverse list -- produce new list */
2748static pointer 2696ecb_hot static pointer
2749reverse (SCHEME_P_ pointer a) 2697reverse (SCHEME_P_ pointer a)
2750{ 2698{
2751 /* a must be checked by gc */ 2699 /* a must be checked by gc */
2752 pointer p = NIL; 2700 pointer p = NIL;
2753 2701
… …
2756 2704
2757 return p; 2705 return p;
2758} 2706}
2759 2707
2760/* reverse list --- in-place */ 2708/* reverse list --- in-place */
2761static pointer 2709ecb_hot static pointer
2762reverse_in_place (SCHEME_P_ pointer term, pointer list) 2710reverse_in_place (SCHEME_P_ pointer term, pointer list)
2763{ 2711{
2764 pointer result = term; 2712 pointer result = term;
2765 pointer p = list; 2713 pointer p = list;
2766 2714
… …
2774 2722
2775 return result; 2723 return result;
2776} 2724}
2777 2725
2778/* append list -- produce new list (in reverse order) */ 2726/* append list -- produce new list (in reverse order) */
2779static pointer 2727ecb_hot static pointer
2780revappend (SCHEME_P_ pointer a, pointer b) 2728revappend (SCHEME_P_ pointer a, pointer b)
2781{ 2729{
2782 pointer result = a; 2730 pointer result = a;
2783 pointer p = b; 2731 pointer p = b;
2784 2732
… …
2793 2741
2794 return S_F; /* signal an error */ 2742 return S_F; /* signal an error */
2795} 2743}
2796 2744
2797/* equivalence of atoms */ 2745/* equivalence of atoms */
2798int 2746ecb_hot int
2799eqv (pointer a, pointer b) 2747eqv (pointer a, pointer b)
2800{ 2748{
2801 if (is_string (a)) 2749 if (is_string (a))
2802 { 2750 {
2803 if (is_string (b)) 2751 if (is_string (b))
… …
2897 } 2845 }
2898 else 2846 else
2899 set_car (env, immutable_cons (slot, car (env))); 2847 set_car (env, immutable_cons (slot, car (env)));
2900} 2848}
2901 2849
2902static pointer 2850ecb_hot static pointer
2903find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2851find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2904{ 2852{
2905 pointer x, y; 2853 pointer x, y;
2906 2854
2907 for (x = env; x != NIL; x = cdr (x)) 2855 for (x = env; x != NIL; x = cdr (x))
… …
2928 return NIL; 2876 return NIL;
2929} 2877}
2930 2878
2931#else /* USE_ALIST_ENV */ 2879#else /* USE_ALIST_ENV */
2932 2880
2933ecb_inline void 2881static void
2934new_frame_in_env (SCHEME_P_ pointer old_env) 2882new_frame_in_env (SCHEME_P_ pointer old_env)
2935{ 2883{
2936 SCHEME_V->envir = immutable_cons (NIL, old_env); 2884 SCHEME_V->envir = immutable_cons (NIL, old_env);
2937 setenvironment (SCHEME_V->envir); 2885 setenvironment (SCHEME_V->envir);
2938} 2886}
2939 2887
2940ecb_inline void 2888static void
2941new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2889new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2942{ 2890{
2943 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2891 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2944} 2892}
2945 2893
2946static pointer 2894ecb_hot static pointer
2947find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2895find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2948{ 2896{
2949 pointer x, y; 2897 pointer x, y;
2950 2898
2951 for (x = env; x != NIL; x = cdr (x)) 2899 for (x = env; x != NIL; x = cdr (x))
… …
2965 return NIL; 2913 return NIL;
2966} 2914}
2967 2915
2968#endif /* USE_ALIST_ENV else */ 2916#endif /* USE_ALIST_ENV else */
2969 2917
2970ecb_inline void 2918static void
2971new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2919new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2972{ 2920{
2973 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 2921 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2974 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2922 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2975} 2923}
2976 2924
2977ecb_inline void 2925static void
2978set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2926set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2979{ 2927{
2980 set_cdr (slot, value); 2928 set_cdr (slot, value);
2981} 2929}
2982 2930
2983ecb_inline pointer 2931static pointer
2984slot_value_in_env (pointer slot) 2932slot_value_in_env (pointer slot)
2985{ 2933{
2986 return cdr (slot); 2934 return cdr (slot);
2987} 2935}
2988 2936
2989/* ========== Evaluation Cycle ========== */ 2937/* ========== Evaluation Cycle ========== */
2990 2938
2991static int 2939ecb_cold static int
2992xError_1 (SCHEME_P_ const char *s, pointer a) 2940xError_1 (SCHEME_P_ const char *s, pointer a)
2993{ 2941{
2994#if USE_ERROR_HOOK 2942#if USE_ERROR_HOOK
2995 pointer x; 2943 pointer x;
2996 pointer hdl = SCHEME_V->ERROR_HOOK; 2944 pointer hdl = SCHEME_V->ERROR_HOOK;
… …
3072 pointer code; 3020 pointer code;
3073}; 3021};
3074 3022
3075# define STACK_GROWTH 3 3023# define STACK_GROWTH 3
3076 3024
3077static void 3025ecb_hot static void
3078s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3026s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3079{ 3027{
3080 int nframes = (uintptr_t)SCHEME_V->dump; 3028 int nframes = (uintptr_t)SCHEME_V->dump;
3081 struct dump_stack_frame *next_frame; 3029 struct dump_stack_frame *next_frame;
3082 3030
3083 /* enough room for the next frame? */ 3031 /* enough room for the next frame? */
3084 if (nframes >= SCHEME_V->dump_size) 3032 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3085 { 3033 {
3086 SCHEME_V->dump_size += STACK_GROWTH; 3034 SCHEME_V->dump_size += STACK_GROWTH;
3087 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); 3035 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3088 } 3036 }
3089 3037
… …
3095 next_frame->code = code; 3043 next_frame->code = code;
3096 3044
3097 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3045 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3098} 3046}
3099 3047
3100static int 3048static ecb_hot int
3101xs_return (SCHEME_P_ pointer a) 3049xs_return (SCHEME_P_ pointer a)
3102{ 3050{
3103 int nframes = (uintptr_t)SCHEME_V->dump; 3051 int nframes = (uintptr_t)SCHEME_V->dump;
3104 struct dump_stack_frame *frame; 3052 struct dump_stack_frame *frame;
3105 3053
… …
3116 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3064 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3117 3065
3118 return 0; 3066 return 0;
3119} 3067}
3120 3068
3121ecb_inline void 3069ecb_cold void
3122dump_stack_reset (SCHEME_P) 3070dump_stack_reset (SCHEME_P)
3123{ 3071{
3124 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3072 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3125 SCHEME_V->dump = (pointer)+0; 3073 SCHEME_V->dump = (pointer)+0;
3126} 3074}
3127 3075
3128ecb_inline void 3076ecb_cold void
3129dump_stack_initialize (SCHEME_P) 3077dump_stack_initialize (SCHEME_P)
3130{ 3078{
3131 SCHEME_V->dump_size = 0; 3079 SCHEME_V->dump_size = 0;
3132 SCHEME_V->dump_base = 0; 3080 SCHEME_V->dump_base = 0;
3133 dump_stack_reset (SCHEME_A); 3081 dump_stack_reset (SCHEME_A);
3134} 3082}
3135 3083
3136static void 3084ecb_cold static void
3137dump_stack_free (SCHEME_P) 3085dump_stack_free (SCHEME_P)
3138{ 3086{
3139 free (SCHEME_V->dump_base); 3087 free (SCHEME_V->dump_base);
3140 SCHEME_V->dump_base = 0; 3088 SCHEME_V->dump_base = 0;
3141 SCHEME_V->dump = (pointer)0; 3089 SCHEME_V->dump = (pointer)0;
3142 SCHEME_V->dump_size = 0; 3090 SCHEME_V->dump_size = 0;
3143} 3091}
3144 3092
3145static void 3093ecb_cold static void
3146dump_stack_mark (SCHEME_P) 3094dump_stack_mark (SCHEME_P)
3147{ 3095{
3148 int nframes = (uintptr_t)SCHEME_V->dump; 3096 int nframes = (uintptr_t)SCHEME_V->dump;
3149 int i; 3097 int i;
3150 3098
… …
3156 mark (frame->envir); 3104 mark (frame->envir);
3157 mark (frame->code); 3105 mark (frame->code);
3158 } 3106 }
3159} 3107}
3160 3108
3161static pointer 3109ecb_cold static pointer
3162ss_get_cont (SCHEME_P) 3110ss_get_cont (SCHEME_P)
3163{ 3111{
3164 int nframes = (uintptr_t)SCHEME_V->dump; 3112 int nframes = (uintptr_t)SCHEME_V->dump;
3165 int i; 3113 int i;
3166 3114
… …
3178 } 3126 }
3179 3127
3180 return cont; 3128 return cont;
3181} 3129}
3182 3130
3183static void 3131ecb_cold static void
3184ss_set_cont (SCHEME_P_ pointer cont) 3132ss_set_cont (SCHEME_P_ pointer cont)
3185{ 3133{
3186 int i = 0; 3134 int i = 0;
3187 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3135 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3188 3136
… …
3200 SCHEME_V->dump = (pointer)(uintptr_t)i; 3148 SCHEME_V->dump = (pointer)(uintptr_t)i;
3201} 3149}
3202 3150
3203#else 3151#else
3204 3152
3205ecb_inline void 3153ecb_cold void
3206dump_stack_reset (SCHEME_P) 3154dump_stack_reset (SCHEME_P)
3207{ 3155{
3208 SCHEME_V->dump = NIL; 3156 SCHEME_V->dump = NIL;
3209} 3157}
3210 3158
3211ecb_inline void 3159ecb_cold void
3212dump_stack_initialize (SCHEME_P) 3160dump_stack_initialize (SCHEME_P)
3213{ 3161{
3214 dump_stack_reset (SCHEME_A); 3162 dump_stack_reset (SCHEME_A);
3215} 3163}
3216 3164
3217static void 3165ecb_cold static void
3218dump_stack_free (SCHEME_P) 3166dump_stack_free (SCHEME_P)
3219{ 3167{
3220 SCHEME_V->dump = NIL; 3168 SCHEME_V->dump = NIL;
3221} 3169}
3222 3170
3223static int 3171ecb_hot static int
3224xs_return (SCHEME_P_ pointer a) 3172xs_return (SCHEME_P_ pointer a)
3225{ 3173{
3226 pointer dump = SCHEME_V->dump; 3174 pointer dump = SCHEME_V->dump;
3227 3175
3228 SCHEME_V->value = a; 3176 SCHEME_V->value = a;
… …
3238 SCHEME_V->dump = dump; 3186 SCHEME_V->dump = dump;
3239 3187
3240 return 0; 3188 return 0;
3241} 3189}
3242 3190
3243static void 3191ecb_hot static void
3244s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3192s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3245{ 3193{
3246 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3194 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3247 cons (args, 3195 cons (args,
3248 cons (SCHEME_V->envir, 3196 cons (SCHEME_V->envir,
3249 cons (code, 3197 cons (code,
3250 SCHEME_V->dump)))); 3198 SCHEME_V->dump))));
3251} 3199}
3252 3200
3201ecb_cold static void
3202dump_stack_mark (SCHEME_P)
3203{
3204 mark (SCHEME_V->dump);
3205}
3206
3207ecb_cold static pointer
3208ss_get_cont (SCHEME_P)
3209{
3210 return SCHEME_V->dump;
3211}
3212
3213ecb_cold static void
3214ss_set_cont (SCHEME_P_ pointer cont)
3215{
3216 SCHEME_V->dump = cont;
3217}
3218
3219#endif
3220
3221#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3222
3223#if EXPERIMENT
3224
3225typedef void *stream[1];
3226
3227#define stream_init() { 0 }
3228
3229ecb_cold static void
3230stream_put (void **s, uint8_t byte)
3231{
3232 uint32_t *sp = *s;
3233 uint32_t size = sizeof (uint32_t) * 2;
3234 uint32_t offs = size;
3235
3236 if (ecb_expect_true (sp))
3237 {
3238 offs = sp[0];
3239 size = sp[1];
3240 }
3241
3242 if (ecb_expect_false (offs == size))
3243 {
3244 size *= 2;
3245 sp = realloc (sp, size);
3246 *s = sp;
3247 sp[1] = size;
3248
3249 }
3250
3251 ((uint8_t *)sp)[offs++] = byte;
3252 sp[0] = offs;
3253}
3254
3255#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
3256#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
3257#define stream_free(s) free (s[0])
3258
3259// calculates a (preferably small) integer that makes it possible to find
3260// the symbol again. if pointers were offsets into a memory area... until
3261// then, we return segment number in the low bits, and offset in the high
3262// bits
3263static uint32_t
3264symbol_id (SCHEME_P_ pointer sym)
3265{
3266 struct cell *p = CELL (sym);
3267 int i;
3268
3269 for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3270 if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3271 {
3272 printf ("seg %d ofs %d/%d\n",i,(p - SCHEME_V->cell_seg[i]),SCHEME_V->cell_segsize[i]);//D
3273 return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3274 }
3275
3276 abort ();
3277}
3278
3253static void 3279static void
3254dump_stack_mark (SCHEME_P) 3280compile (SCHEME_P_ stream s, pointer x)
3255{ 3281{
3256 mark (SCHEME_V->dump); 3282 if (x == NIL)
3257} 3283 {
3284 stream_put (s, 0);
3285 return;
3286 }
3258 3287
3259static pointer 3288 if (is_syntax (x))
3260ss_get_cont (SCHEME_P) 3289 {
3261{ 3290 stream_put (s, 1);
3262 return SCHEME_V->dump; 3291 stream_put (s, syntaxnum (x));
3263} 3292 return;
3293 }
3264 3294
3265static void 3295 switch (type (x))
3266ss_set_cont (SCHEME_P_ pointer cont) 3296 {
3267{ 3297 case T_INTEGER:
3268 SCHEME_V->dump = cont; 3298 stream_put (s, 2);
3269} 3299 stream_put (s, 0);
3300 stream_put (s, 0);
3301 stream_put (s, 0);
3302 stream_put (s, 0);
3303 return;
3270 3304
3271#endif 3305 case T_SYMBOL:
3306 {
3307 uint32_t sym = symbol_id (SCHEME_A_ x);
3308 printf ("sym %x\n", sym);//D
3272 3309
3273#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3310 stream_put (s, 3);
3274 3311
3275#if EXPERIMENT 3312 while (sym > 0x7f)
3313 {
3314 stream_put (s, sym | 0x80);
3315 sym >>= 8;
3316 }
3317
3318 stream_put (s, sym);
3319 }
3320 return;
3321
3322 case T_PAIR:
3323 stream_put (s, 4);
3324 while (x != NIL)
3325 {
3326 compile (SCHEME_A_ s, car (x));
3327 x = cdr (x);
3328 }
3329 stream_put (s, 0xff);
3330 return;
3331
3332 default:
3333 stream_put (s, 5);
3334 stream_put (s, type (x));
3335 stream_put (s, 0);
3336 stream_put (s, 0);
3337 stream_put (s, 0);
3338 stream_put (s, 0);
3339 break;
3340 }
3341}
3342
3276static int 3343static int
3344compile_closure (SCHEME_P_ pointer p)
3345{
3346 stream s = stream_init ();
3347
3348 printatom (SCHEME_A_ p, 1);//D
3349 compile (SCHEME_A_ s, car (p));
3350
3351 FILE *xxd = popen ("xxd", "we");
3352 fwrite (stream_data (s), 1, stream_size (s), xxd);
3353 fclose (xxd);
3354
3355 return stream_size (s);
3356}
3357
3358static int
3277debug (SCHEME_P_ int indent, pointer x) 3359dtree (SCHEME_P_ int indent, pointer x)
3278{ 3360{
3279 int c; 3361 int c;
3280 3362
3281 if (is_syntax (x)) 3363 if (is_syntax (x))
3282 { 3364 {
… …
3300 printf ("%*sS<%s>\n", indent, "", symname (x)); 3382 printf ("%*sS<%s>\n", indent, "", symname (x));
3301 return 24+8; 3383 return 24+8;
3302 3384
3303 case T_CLOSURE: 3385 case T_CLOSURE:
3304 printf ("%*sS<%s>\n", indent, "", "closure"); 3386 printf ("%*sS<%s>\n", indent, "", "closure");
3305 debug (SCHEME_A_ indent + 3, cdr(x)); 3387 dtree (SCHEME_A_ indent + 3, cdr(x));
3306 return 32 + debug (SCHEME_A_ indent + 3, car (x)); 3388 return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3307 3389
3308 case T_PAIR: 3390 case T_PAIR:
3309 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); 3391 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3310 c = debug (SCHEME_A_ indent + 3, car (x)); 3392 c = dtree (SCHEME_A_ indent + 3, car (x));
3311 c += debug (SCHEME_A_ indent + 3, cdr (x)); 3393 c += dtree (SCHEME_A_ indent + 3, cdr (x));
3312 return c + 1; 3394 return c + 1;
3313 3395
3314 case T_PORT: 3396 case T_PORT:
3315 printf ("%*sS<%s>\n", indent, "", "port"); 3397 printf ("%*sS<%s>\n", indent, "", "port");
3316 return 24+8; 3398 return 24+8;
… …
3319 printf ("%*sS<%s>\n", indent, "", "vector"); 3401 printf ("%*sS<%s>\n", indent, "", "vector");
3320 return 24+8; 3402 return 24+8;
3321 3403
3322 case T_ENVIRONMENT: 3404 case T_ENVIRONMENT:
3323 printf ("%*sS<%s>\n", indent, "", "environment"); 3405 printf ("%*sS<%s>\n", indent, "", "environment");
3324 return 0 + debug (SCHEME_A_ indent + 3, car (x)); 3406 return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3325 3407
3326 default: 3408 default:
3327 printf ("unhandled type %d\n", type (x)); 3409 printf ("unhandled type %d\n", type (x));
3328 break; 3410 break;
3329 } 3411 }
3330} 3412}
3331#endif 3413#endif
3332 3414
3333static int 3415/* syntax, eval, core, ... */
3416ecb_hot static int
3334opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3417opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3335{ 3418{
3336 pointer args = SCHEME_V->args; 3419 pointer args = SCHEME_V->args;
3337 pointer x, y; 3420 pointer x, y;
3338 3421
3339 switch (op) 3422 switch (op)
3340 { 3423 {
3341#if EXPERIMENT //D 3424#if EXPERIMENT //D
3342 case OP_DEBUG: 3425 case OP_DEBUG:
3343 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3426 {
3427 uint32_t len = compile_closure (SCHEME_A_ car (args));
3428 printf ("len = %d\n", len);
3344 printf ("\n"); 3429 printf ("\n");
3345 s_return (S_T); 3430 s_return (S_T);
3431 }
3346#endif 3432#endif
3347 case OP_LOAD: /* load */ 3433 case OP_LOAD: /* load */
3348 if (file_interactive (SCHEME_A)) 3434 if (file_interactive (SCHEME_A))
3349 { 3435 {
3350 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3436 putstr (SCHEME_A_ "Loading ");
3351 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3437 putstr (SCHEME_A_ strvalue (car (args)));
3438 putcharacter (SCHEME_A_ '\n');
3352 } 3439 }
3353 3440
3354 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3441 if (!file_push (SCHEME_A_ strvalue (car (args))))
3355 Error_1 ("unable to open", car (args)); 3442 Error_1 ("unable to open", car (args));
3356 else 3443
3357 {
3358 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3444 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3359 s_goto (OP_T0LVL); 3445 s_goto (OP_T0LVL);
3360 }
3361 3446
3362 case OP_T0LVL: /* top level */ 3447 case OP_T0LVL: /* top level */
3363 3448
3364 /* If we reached the end of file, this loop is done. */ 3449 /* If we reached the end of file, this loop is done. */
3365 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3450 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3366 { 3451 {
3367 if (SCHEME_V->file_i == 0) 3452 if (SCHEME_V->file_i == 0)
3368 { 3453 {
3369 SCHEME_V->args = NIL; 3454 SCHEME_V->args = NIL;
3370 s_goto (OP_QUIT); 3455 s_goto (OP_QUIT);
… …
3381 /* If interactive, be nice to user. */ 3466 /* If interactive, be nice to user. */
3382 if (file_interactive (SCHEME_A)) 3467 if (file_interactive (SCHEME_A))
3383 { 3468 {
3384 SCHEME_V->envir = SCHEME_V->global_env; 3469 SCHEME_V->envir = SCHEME_V->global_env;
3385 dump_stack_reset (SCHEME_A); 3470 dump_stack_reset (SCHEME_A);
3386 putstr (SCHEME_A_ "\n"); 3471 putcharacter (SCHEME_A_ '\n');
3472#if EXPERIMENT
3473 system ("ps v $PPID");
3474#endif
3387 putstr (SCHEME_A_ prompt); 3475 putstr (SCHEME_A_ prompt);
3388 } 3476 }
3389 3477
3390 /* Set up another iteration of REPL */ 3478 /* Set up another iteration of REPL */
3391 SCHEME_V->nesting = 0; 3479 SCHEME_V->nesting = 0;
… …
3426 { 3514 {
3427 SCHEME_V->print_flag = 1; 3515 SCHEME_V->print_flag = 1;
3428 SCHEME_V->args = SCHEME_V->value; 3516 SCHEME_V->args = SCHEME_V->value;
3429 s_goto (OP_P0LIST); 3517 s_goto (OP_P0LIST);
3430 } 3518 }
3431 else 3519
3432 s_return (SCHEME_V->value); 3520 s_return (SCHEME_V->value);
3433 3521
3434 case OP_EVAL: /* main part of evaluation */ 3522 case OP_EVAL: /* main part of evaluation */
3435#if USE_TRACING 3523#if USE_TRACING
3436 if (SCHEME_V->tracing) 3524 if (SCHEME_V->tracing)
3437 { 3525 {
… …
3448#endif 3536#endif
3449 if (is_symbol (SCHEME_V->code)) /* symbol */ 3537 if (is_symbol (SCHEME_V->code)) /* symbol */
3450 { 3538 {
3451 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3539 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3452 3540
3453 if (x != NIL) 3541 if (x == NIL)
3454 s_return (slot_value_in_env (x));
3455 else
3456 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3542 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3543
3544 s_return (slot_value_in_env (x));
3457 } 3545 }
3458 else if (is_pair (SCHEME_V->code)) 3546 else if (is_pair (SCHEME_V->code))
3459 { 3547 {
3460 x = car (SCHEME_V->code); 3548 x = car (SCHEME_V->code);
3461 3549
… …
3470 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3558 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3471 SCHEME_V->code = x; 3559 SCHEME_V->code = x;
3472 s_goto (OP_EVAL); 3560 s_goto (OP_EVAL);
3473 } 3561 }
3474 } 3562 }
3475 else 3563
3476 s_return (SCHEME_V->code); 3564 s_return (SCHEME_V->code);
3477 3565
3478 case OP_E0ARGS: /* eval arguments */ 3566 case OP_E0ARGS: /* eval arguments */
3479 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ 3567 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3480 { 3568 {
3481 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3569 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
… …
3538 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3626 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3539 else if (is_foreign (SCHEME_V->code)) 3627 else if (is_foreign (SCHEME_V->code))
3540 { 3628 {
3541 /* Keep nested calls from GC'ing the arglist */ 3629 /* Keep nested calls from GC'ing the arglist */
3542 push_recent_alloc (SCHEME_A_ args, NIL); 3630 push_recent_alloc (SCHEME_A_ args, NIL);
3543 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3631 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3544 3632
3545 s_return (x); 3633 s_return (x);
3546 } 3634 }
3547 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3635 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3548 { 3636 {
… …
3653 else 3741 else
3654 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 3742 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3655 3743
3656 s_return (SCHEME_V->code); 3744 s_return (SCHEME_V->code);
3657 3745
3658
3659 case OP_DEFP: /* defined? */ 3746 case OP_DEFP: /* defined? */
3660 x = SCHEME_V->envir; 3747 x = SCHEME_V->envir;
3661 3748
3662 if (cdr (args) != NIL) 3749 if (cdr (args) != NIL)
3663 x = cadr (args); 3750 x = cadr (args);
… …
3680 set_slot_in_env (SCHEME_A_ y, SCHEME_V->value); 3767 set_slot_in_env (SCHEME_A_ y, SCHEME_V->value);
3681 s_return (SCHEME_V->value); 3768 s_return (SCHEME_V->value);
3682 } 3769 }
3683 else 3770 else
3684 Error_1 ("set!: unbound variable:", SCHEME_V->code); 3771 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3685
3686 3772
3687 case OP_BEGIN: /* begin */ 3773 case OP_BEGIN: /* begin */
3688 if (!is_pair (SCHEME_V->code)) 3774 if (!is_pair (SCHEME_V->code))
3689 s_return (SCHEME_V->code); 3775 s_return (SCHEME_V->code);
3690 3776
… …
3702 case OP_IF1: /* if */ 3788 case OP_IF1: /* if */
3703 if (is_true (SCHEME_V->value)) 3789 if (is_true (SCHEME_V->value))
3704 SCHEME_V->code = car (SCHEME_V->code); 3790 SCHEME_V->code = car (SCHEME_V->code);
3705 else 3791 else
3706 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ 3792 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3793
3707 s_goto (OP_EVAL); 3794 s_goto (OP_EVAL);
3708 3795
3709 case OP_LET0: /* let */ 3796 case OP_LET0: /* let */
3710 SCHEME_V->args = NIL; 3797 SCHEME_V->args = NIL;
3711 SCHEME_V->value = SCHEME_V->code; 3798 SCHEME_V->value = SCHEME_V->code;
… …
3867 } 3954 }
3868 else 3955 else
3869 { 3956 {
3870 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) 3957 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3871 s_return (NIL); 3958 s_return (NIL);
3872 else 3959
3873 {
3874 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 3960 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3875 SCHEME_V->code = caar (SCHEME_V->code); 3961 SCHEME_V->code = caar (SCHEME_V->code);
3876 s_goto (OP_EVAL); 3962 s_goto (OP_EVAL);
3877 }
3878 } 3963 }
3879 3964
3880 case OP_DELAY: /* delay */ 3965 case OP_DELAY: /* delay */
3881 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 3966 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3882 set_typeflag (x, T_PROMISE); 3967 set_typeflag (x, T_PROMISE);
… …
3893 case OP_AND1: /* and */ 3978 case OP_AND1: /* and */
3894 if (is_false (SCHEME_V->value)) 3979 if (is_false (SCHEME_V->value))
3895 s_return (SCHEME_V->value); 3980 s_return (SCHEME_V->value);
3896 else if (SCHEME_V->code == NIL) 3981 else if (SCHEME_V->code == NIL)
3897 s_return (SCHEME_V->value); 3982 s_return (SCHEME_V->value);
3898 else 3983
3899 {
3900 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 3984 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3901 SCHEME_V->code = car (SCHEME_V->code); 3985 SCHEME_V->code = car (SCHEME_V->code);
3902 s_goto (OP_EVAL); 3986 s_goto (OP_EVAL);
3903 }
3904 3987
3905 case OP_OR0: /* or */ 3988 case OP_OR0: /* or */
3906 if (SCHEME_V->code == NIL) 3989 if (SCHEME_V->code == NIL)
3907 s_return (S_F); 3990 s_return (S_F);
3908 3991
… …
3913 case OP_OR1: /* or */ 3996 case OP_OR1: /* or */
3914 if (is_true (SCHEME_V->value)) 3997 if (is_true (SCHEME_V->value))
3915 s_return (SCHEME_V->value); 3998 s_return (SCHEME_V->value);
3916 else if (SCHEME_V->code == NIL) 3999 else if (SCHEME_V->code == NIL)
3917 s_return (SCHEME_V->value); 4000 s_return (SCHEME_V->value);
3918 else 4001
3919 {
3920 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 4002 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3921 SCHEME_V->code = car (SCHEME_V->code); 4003 SCHEME_V->code = car (SCHEME_V->code);
3922 s_goto (OP_EVAL); 4004 s_goto (OP_EVAL);
3923 }
3924 4005
3925 case OP_C0STREAM: /* cons-stream */ 4006 case OP_C0STREAM: /* cons-stream */
3926 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 4007 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3927 SCHEME_V->code = car (SCHEME_V->code); 4008 SCHEME_V->code = car (SCHEME_V->code);
3928 s_goto (OP_EVAL); 4009 s_goto (OP_EVAL);
… …
3993 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x)); 4074 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3994 SCHEME_V->code = caar (x); 4075 SCHEME_V->code = caar (x);
3995 s_goto (OP_EVAL); 4076 s_goto (OP_EVAL);
3996 } 4077 }
3997 } 4078 }
3998 else 4079
3999 s_return (NIL); 4080 s_return (NIL);
4000 4081
4001 case OP_CASE2: /* case */ 4082 case OP_CASE2: /* case */
4002 if (is_true (SCHEME_V->value)) 4083 if (is_true (SCHEME_V->value))
4003 s_goto (OP_BEGIN); 4084 s_goto (OP_BEGIN);
4004 else 4085
4005 s_return (NIL); 4086 s_return (NIL);
4006 4087
4007 case OP_PAPPLY: /* apply */ 4088 case OP_PAPPLY: /* apply */
4008 SCHEME_V->code = car (args); 4089 SCHEME_V->code = car (args);
4009 SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); 4090 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
4010 /*SCHEME_V->args = cadr(args); */ 4091 /*SCHEME_V->args = cadr(args); */
… …
4024 } 4105 }
4025 4106
4026 if (USE_ERROR_CHECKING) abort (); 4107 if (USE_ERROR_CHECKING) abort ();
4027} 4108}
4028 4109
4029static int 4110/* math, cxr */
4111ecb_hot static int
4030opexe_1 (SCHEME_P_ enum scheme_opcodes op) 4112opexe_1 (SCHEME_P_ enum scheme_opcodes op)
4031{ 4113{
4032 pointer args = SCHEME_V->args; 4114 pointer args = SCHEME_V->args;
4033 pointer x = car (args); 4115 pointer x = car (args);
4034 num v; 4116 num v;
4035 4117
4036 switch (op) 4118 switch (op)
4037 { 4119 {
4038#if USE_MATH 4120#if USE_MATH
4039 case OP_INEX2EX: /* inexact->exact */ 4121 case OP_INEX2EX: /* inexact->exact */
4040 {
4041 if (is_integer (x)) 4122 if (!is_integer (x))
4042 s_return (x); 4123 {
4043
4044 RVALUE r = rvalue_unchecked (x); 4124 RVALUE r = rvalue_unchecked (x);
4045 4125
4046 if (r == (RVALUE)(IVALUE)r) 4126 if (r == (RVALUE)(IVALUE)r)
4047 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4127 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4048 else 4128 else
4049 Error_1 ("inexact->exact: not integral:", x); 4129 Error_1 ("inexact->exact: not integral:", x);
4050 } 4130 }
4051 4131
4132 s_return (x);
4133
4134 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4135 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4136 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4137 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4138
4139 case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4052 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4140 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4053 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4141 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4142 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4054 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4143 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4055 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4144 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4056 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4145 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4057 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4146 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4058 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4147 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4059 4148
4060 case OP_ATAN: 4149 case OP_ATAN:
4150 s_return (mk_real (SCHEME_A_
4061 if (cdr (args) == NIL) 4151 cdr (args) == NIL
4062 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4152 ? atan (rvalue (x))
4063 else 4153 : atan2 (rvalue (x), rvalue (cadr (args)))));
4064 {
4065 pointer y = cadr (args);
4066 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4067 }
4068
4069 case OP_SQRT:
4070 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4071 4154
4072 case OP_EXPT: 4155 case OP_EXPT:
4073 { 4156 {
4074 RVALUE result; 4157 RVALUE result;
4075 int real_result = 1; 4158 int real_result = 1;
… …
4098 if (real_result) 4181 if (real_result)
4099 s_return (mk_real (SCHEME_A_ result)); 4182 s_return (mk_real (SCHEME_A_ result));
4100 else 4183 else
4101 s_return (mk_integer (SCHEME_A_ result)); 4184 s_return (mk_integer (SCHEME_A_ result));
4102 } 4185 }
4103
4104 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4105 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4106
4107 case OP_TRUNCATE:
4108 {
4109 RVALUE n = rvalue (x);
4110 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4111 }
4112
4113 case OP_ROUND:
4114 if (is_integer (x))
4115 s_return (x);
4116
4117 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4118#endif 4186#endif
4119 4187
4120 case OP_ADD: /* + */ 4188 case OP_ADD: /* + */
4121 v = num_zero; 4189 v = num_zero;
4122 4190
… …
4424 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4492 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4425 4493
4426 s_return (newstr); 4494 s_return (newstr);
4427 } 4495 }
4428 4496
4429 case OP_SUBSTR: /* substring */ 4497 case OP_STRING_COPY: /* substring/string-copy */
4430 { 4498 {
4431 char *str = strvalue (x); 4499 char *str = strvalue (x);
4432 int index0 = ivalue_unchecked (cadr (args)); 4500 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4433 int index1; 4501 int index1;
4434 int len; 4502 int len;
4435 4503
4436 if (index0 > strlength (x)) 4504 if (index0 > strlength (x))
4437 Error_1 ("substring: start out of bounds:", cadr (args)); 4505 Error_1 ("string->copy: start out of bounds:", cadr (args));
4438 4506
4439 if (cddr (args) != NIL) 4507 if (cddr (args) != NIL)
4440 { 4508 {
4441 index1 = ivalue_unchecked (caddr (args)); 4509 index1 = ivalue_unchecked (caddr (args));
4442 4510
4443 if (index1 > strlength (x) || index1 < index0) 4511 if (index1 > strlength (x) || index1 < index0)
4444 Error_1 ("substring: end out of bounds:", caddr (args)); 4512 Error_1 ("string->copy: end out of bounds:", caddr (args));
4445 } 4513 }
4446 else 4514 else
4447 index1 = strlength (x); 4515 index1 = strlength (x);
4448 4516
4449 len = index1 - index0; 4517 len = index1 - index0;
4450 x = mk_empty_string (SCHEME_A_ len, ' '); 4518 x = mk_counted_string (SCHEME_A_ str + index0, len);
4451 memcpy (strvalue (x), str + index0, len);
4452 strvalue (x)[len] = 0;
4453 4519
4454 s_return (x); 4520 s_return (x);
4455 } 4521 }
4456 4522
4457 case OP_VECTOR: /* vector */ 4523 case OP_VECTOR: /* vector */
… …
4531 } 4597 }
4532 4598
4533 if (USE_ERROR_CHECKING) abort (); 4599 if (USE_ERROR_CHECKING) abort ();
4534} 4600}
4535 4601
4536static int 4602/* relational ops */
4603ecb_hot static int
4537opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4604opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4538{ 4605{
4539 pointer x = SCHEME_V->args; 4606 pointer x = SCHEME_V->args;
4540 4607
4541 for (;;) 4608 for (;;)
… …
4562 } 4629 }
4563 4630
4564 s_return (S_T); 4631 s_return (S_T);
4565} 4632}
4566 4633
4567static int 4634/* predicates */
4635ecb_hot static int
4568opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4636opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4569{ 4637{
4570 pointer args = SCHEME_V->args; 4638 pointer args = SCHEME_V->args;
4571 pointer a = car (args); 4639 pointer a = car (args);
4572 pointer d = cdr (args); 4640 pointer d = cdr (args);
… …
4619 } 4687 }
4620 4688
4621 s_retbool (r); 4689 s_retbool (r);
4622} 4690}
4623 4691
4624static int 4692/* promises, list ops, ports */
4693ecb_hot static int
4625opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4694opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4626{ 4695{
4627 pointer args = SCHEME_V->args; 4696 pointer args = SCHEME_V->args;
4628 pointer a = car (args); 4697 pointer a = car (args);
4629 pointer x, y; 4698 pointer x, y;
… …
4642 } 4711 }
4643 else 4712 else
4644 s_return (SCHEME_V->code); 4713 s_return (SCHEME_V->code);
4645 4714
4646 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4715 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4647 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4716 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4648 s_return (SCHEME_V->value); 4717 s_return (SCHEME_V->value);
4649 4718
4650#if USE_PORTS 4719#if USE_PORTS
4720
4721 case OP_EOF_OBJECT: /* eof-object */
4722 s_return (S_EOF);
4651 4723
4652 case OP_WRITE: /* write */ 4724 case OP_WRITE: /* write */
4653 case OP_DISPLAY: /* display */ 4725 case OP_DISPLAY: /* display */
4654 case OP_WRITE_CHAR: /* write-char */ 4726 case OP_WRITE_CHAR: /* write-char */
4655 if (is_pair (cdr (SCHEME_V->args))) 4727 if (is_pair (cdr (SCHEME_V->args)))
… …
4669 else 4741 else
4670 SCHEME_V->print_flag = 0; 4742 SCHEME_V->print_flag = 0;
4671 4743
4672 s_goto (OP_P0LIST); 4744 s_goto (OP_P0LIST);
4673 4745
4746 //TODO: move to scheme
4674 case OP_NEWLINE: /* newline */ 4747 case OP_NEWLINE: /* newline */
4675 if (is_pair (args)) 4748 if (is_pair (args))
4676 { 4749 {
4677 if (a != SCHEME_V->outport) 4750 if (a != SCHEME_V->outport)
4678 { 4751 {
… …
4680 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4753 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4681 SCHEME_V->outport = a; 4754 SCHEME_V->outport = a;
4682 } 4755 }
4683 } 4756 }
4684 4757
4685 putstr (SCHEME_A_ "\n"); 4758 putcharacter (SCHEME_A_ '\n');
4686 s_return (S_T); 4759 s_return (S_T);
4687#endif 4760#endif
4688 4761
4689 case OP_ERR0: /* error */ 4762 case OP_ERR0: /* error */
4690 SCHEME_V->retcode = -1; 4763 SCHEME_V->retcode = -1;
… …
4699 putstr (SCHEME_A_ strvalue (car (args))); 4772 putstr (SCHEME_A_ strvalue (car (args)));
4700 SCHEME_V->args = cdr (args); 4773 SCHEME_V->args = cdr (args);
4701 s_goto (OP_ERR1); 4774 s_goto (OP_ERR1);
4702 4775
4703 case OP_ERR1: /* error */ 4776 case OP_ERR1: /* error */
4704 putstr (SCHEME_A_ " "); 4777 putcharacter (SCHEME_A_ ' ');
4705 4778
4706 if (args != NIL) 4779 if (args != NIL)
4707 { 4780 {
4708 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); 4781 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4709 SCHEME_V->args = a; 4782 SCHEME_V->args = a;
4710 SCHEME_V->print_flag = 1; 4783 SCHEME_V->print_flag = 1;
4711 s_goto (OP_P0LIST); 4784 s_goto (OP_P0LIST);
4712 } 4785 }
4713 else 4786 else
4714 { 4787 {
4715 putstr (SCHEME_A_ "\n"); 4788 putcharacter (SCHEME_A_ '\n');
4716 4789
4717 if (SCHEME_V->interactive_repl) 4790 if (SCHEME_V->interactive_repl)
4718 s_goto (OP_T0LVL); 4791 s_goto (OP_T0LVL);
4719 else 4792 else
4720 return -1; 4793 return -1;
… …
4797 SCHEME_V->gc_verbose = (a != S_F); 4870 SCHEME_V->gc_verbose = (a != S_F);
4798 s_retbool (was); 4871 s_retbool (was);
4799 } 4872 }
4800 4873
4801 case OP_NEWSEGMENT: /* new-segment */ 4874 case OP_NEWSEGMENT: /* new-segment */
4875#if 0
4802 if (!is_pair (args) || !is_number (a)) 4876 if (!is_pair (args) || !is_number (a))
4803 Error_0 ("new-segment: argument must be a number"); 4877 Error_0 ("new-segment: argument must be a number");
4804 4878#endif
4805 alloc_cellseg (SCHEME_A_ ivalue (a)); 4879 s_retbool (alloc_cellseg (SCHEME_A));
4806
4807 s_return (S_T);
4808 4880
4809 case OP_OBLIST: /* oblist */ 4881 case OP_OBLIST: /* oblist */
4810 s_return (oblist_all_symbols (SCHEME_A)); 4882 s_return (oblist_all_symbols (SCHEME_A));
4811 4883
4812#if USE_PORTS 4884#if USE_PORTS
… …
4882 s_return (p == NIL ? S_F : p); 4954 s_return (p == NIL ? S_F : p);
4883 } 4955 }
4884 4956
4885 case OP_GET_OUTSTRING: /* get-output-string */ 4957 case OP_GET_OUTSTRING: /* get-output-string */
4886 { 4958 {
4887 port *p; 4959 port *p = port (a);
4888 4960
4889 if ((p = a->object.port)->kind & port_string) 4961 if (p->kind & port_string)
4890 { 4962 {
4891 off_t size; 4963 off_t size;
4892 char *str; 4964 char *str;
4893 4965
4894 size = p->rep.string.curr - p->rep.string.start + 1; 4966 size = p->rep.string.curr - p->rep.string.start + 1;
… …
4929 } 5001 }
4930 5002
4931 if (USE_ERROR_CHECKING) abort (); 5003 if (USE_ERROR_CHECKING) abort ();
4932} 5004}
4933 5005
4934static int 5006/* reading */
5007ecb_cold static int
4935opexe_5 (SCHEME_P_ enum scheme_opcodes op) 5008opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4936{ 5009{
4937 pointer args = SCHEME_V->args; 5010 pointer args = SCHEME_V->args;
4938 pointer x; 5011 pointer x;
4939 5012
… …
4999 int res; 5072 int res;
5000 5073
5001 if (is_pair (args)) 5074 if (is_pair (args))
5002 p = car (args); 5075 p = car (args);
5003 5076
5004 res = p->object.port->kind & port_string; 5077 res = port (p)->kind & port_string;
5005 5078
5006 s_retbool (res); 5079 s_retbool (res);
5007 } 5080 }
5008 5081
5009 case OP_SET_INPORT: /* set-input-port */ 5082 case OP_SET_INPORT: /* set-input-port */
… …
5208 pointer b = cdr (args); 5281 pointer b = cdr (args);
5209 int ok_abbr = ok_abbrev (b); 5282 int ok_abbr = ok_abbrev (b);
5210 SCHEME_V->args = car (b); 5283 SCHEME_V->args = car (b);
5211 5284
5212 if (a == SCHEME_V->QUOTE && ok_abbr) 5285 if (a == SCHEME_V->QUOTE && ok_abbr)
5213 putstr (SCHEME_A_ "'"); 5286 putcharacter (SCHEME_A_ '\'');
5214 else if (a == SCHEME_V->QQUOTE && ok_abbr) 5287 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5215 putstr (SCHEME_A_ "`"); 5288 putcharacter (SCHEME_A_ '`');
5216 else if (a == SCHEME_V->UNQUOTE && ok_abbr) 5289 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5217 putstr (SCHEME_A_ ","); 5290 putcharacter (SCHEME_A_ ',');
5218 else if (a == SCHEME_V->UNQUOTESP && ok_abbr) 5291 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5219 putstr (SCHEME_A_ ",@"); 5292 putstr (SCHEME_A_ ",@");
5220 else 5293 else
5221 { 5294 {
5222 putstr (SCHEME_A_ "("); 5295 putcharacter (SCHEME_A_ '(');
5223 s_save (SCHEME_A_ OP_P1LIST, b, NIL); 5296 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5224 SCHEME_V->args = a; 5297 SCHEME_V->args = a;
5225 } 5298 }
5226 5299
5227 s_goto (OP_P0LIST); 5300 s_goto (OP_P0LIST);
… …
5229 5302
5230 case OP_P1LIST: 5303 case OP_P1LIST:
5231 if (is_pair (args)) 5304 if (is_pair (args))
5232 { 5305 {
5233 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); 5306 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5234 putstr (SCHEME_A_ " "); 5307 putcharacter (SCHEME_A_ ' ');
5235 SCHEME_V->args = car (args); 5308 SCHEME_V->args = car (args);
5236 s_goto (OP_P0LIST); 5309 s_goto (OP_P0LIST);
5237 } 5310 }
5238 else if (is_vector (args)) 5311 else if (is_vector (args))
5239 { 5312 {
… …
5247 { 5320 {
5248 putstr (SCHEME_A_ " . "); 5321 putstr (SCHEME_A_ " . ");
5249 printatom (SCHEME_A_ args, SCHEME_V->print_flag); 5322 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5250 } 5323 }
5251 5324
5252 putstr (SCHEME_A_ ")"); 5325 putcharacter (SCHEME_A_ ')');
5253 s_return (S_T); 5326 s_return (S_T);
5254 } 5327 }
5255 5328
5256 case OP_PVECFROM: 5329 case OP_PVECFROM:
5257 { 5330 {
… …
5259 pointer vec = car (args); 5332 pointer vec = car (args);
5260 int len = veclength (vec); 5333 int len = veclength (vec);
5261 5334
5262 if (i == len) 5335 if (i == len)
5263 { 5336 {
5264 putstr (SCHEME_A_ ")"); 5337 putcharacter (SCHEME_A_ ')');
5265 s_return (S_T); 5338 s_return (S_T);
5266 } 5339 }
5267 else 5340 else
5268 { 5341 {
5269 pointer elem = vector_get (vec, i); 5342 pointer elem = vector_get (vec, i);
… …
5271 ivalue_unchecked (cdr (args)) = i + 1; 5344 ivalue_unchecked (cdr (args)) = i + 1;
5272 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5345 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5273 SCHEME_V->args = elem; 5346 SCHEME_V->args = elem;
5274 5347
5275 if (i > 0) 5348 if (i > 0)
5276 putstr (SCHEME_A_ " "); 5349 putcharacter (SCHEME_A_ ' ');
5277 5350
5278 s_goto (OP_P0LIST); 5351 s_goto (OP_P0LIST);
5279 } 5352 }
5280 } 5353 }
5281 } 5354 }
5282 5355
5283 if (USE_ERROR_CHECKING) abort (); 5356 if (USE_ERROR_CHECKING) abort ();
5284} 5357}
5285 5358
5286static int 5359/* list ops */
5360ecb_hot static int
5287opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5361opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5288{ 5362{
5289 pointer args = SCHEME_V->args; 5363 pointer args = SCHEME_V->args;
5290 pointer a = car (args); 5364 pointer a = car (args);
5291 pointer x, y; 5365 pointer x, y;
… …
5314 break; 5388 break;
5315 } 5389 }
5316 5390
5317 if (is_pair (y)) 5391 if (is_pair (y))
5318 s_return (car (y)); 5392 s_return (car (y));
5319 else 5393
5320 s_return (S_F); 5394 s_return (S_F);
5321
5322 5395
5323 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5396 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5324 SCHEME_V->args = a; 5397 SCHEME_V->args = a;
5325 5398
5326 if (SCHEME_V->args == NIL) 5399 if (SCHEME_V->args == NIL)
5327 s_return (S_F); 5400 s_return (S_F);
5328 else if (is_closure (SCHEME_V->args)) 5401 else if (is_closure (SCHEME_V->args) || is_macro (SCHEME_V->args))
5329 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5402 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5330 else if (is_macro (SCHEME_V->args)) 5403
5331 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5332 else
5333 s_return (S_F); 5404 s_return (S_F);
5334 5405
5335 case OP_CLOSUREP: /* closure? */ 5406 case OP_CLOSUREP: /* closure? */
5336 /* 5407 /*
5337 * Note, macro object is also a closure. 5408 * Note, macro object is also a closure.
5338 * Therefore, (closure? <#MACRO>) ==> #t 5409 * Therefore, (closure? <#MACRO>) ==> #t
… …
5349 5420
5350/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5421/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5351typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); 5422typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5352 5423
5353typedef int (*test_predicate)(pointer); 5424typedef int (*test_predicate)(pointer);
5354static int 5425
5426ecb_hot static int
5355tst_any (pointer p) 5427tst_any (pointer p)
5356{ 5428{
5357 return 1; 5429 return 1;
5358} 5430}
5359 5431
5360static int 5432ecb_hot static int
5361tst_inonneg (pointer p) 5433tst_inonneg (pointer p)
5362{ 5434{
5363 return is_integer (p) && ivalue_unchecked (p) >= 0; 5435 return is_integer (p) && ivalue_unchecked (p) >= 0;
5364} 5436}
5365 5437
5366static int 5438ecb_hot static int
5367tst_is_list (SCHEME_P_ pointer p) 5439tst_is_list (SCHEME_P_ pointer p)
5368{ 5440{
5369 return p == NIL || is_pair (p); 5441 return p == NIL || is_pair (p);
5370} 5442}
5371 5443
… …
5414#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" 5486#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5415#include "opdefines.h" 5487#include "opdefines.h"
5416#undef OP_DEF 5488#undef OP_DEF
5417; 5489;
5418 5490
5419static const char * 5491ecb_cold static const char *
5420opname (int idx) 5492opname (int idx)
5421{ 5493{
5422 const char *name = opnames; 5494 const char *name = opnames;
5423 5495
5424 /* should do this at compile time, but would require external program, right? */ 5496 /* should do this at compile time, but would require external program, right? */
… …
5426 name += strlen (name) + 1; 5498 name += strlen (name) + 1;
5427 5499
5428 return *name ? name : "ILLEGAL"; 5500 return *name ? name : "ILLEGAL";
5429} 5501}
5430 5502
5431static const char * 5503ecb_cold static const char *
5432procname (pointer x) 5504procname (pointer x)
5433{ 5505{
5434 return opname (procnum (x)); 5506 return opname (procnum (x));
5435} 5507}
5436 5508
… …
5456#undef OP_DEF 5528#undef OP_DEF
5457 {0} 5529 {0}
5458}; 5530};
5459 5531
5460/* kernel of this interpreter */ 5532/* kernel of this interpreter */
5461static void ecb_hot 5533ecb_hot static void
5462Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5534Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5463{ 5535{
5464 SCHEME_V->op = op; 5536 SCHEME_V->op = op;
5465 5537
5466 for (;;) 5538 for (;;)
… …
5549 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) 5621 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5550 return; 5622 return;
5551 5623
5552 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5624 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5553 { 5625 {
5554 xwrstr ("No memory!\n"); 5626 putstr (SCHEME_A_ "No memory!\n");
5555 return; 5627 return;
5556 } 5628 }
5557 } 5629 }
5558} 5630}
5559 5631
5560/* ========== Initialization of internal keywords ========== */ 5632/* ========== Initialization of internal keywords ========== */
5561 5633
5562static void 5634ecb_cold static void
5563assign_syntax (SCHEME_P_ const char *name) 5635assign_syntax (SCHEME_P_ const char *name)
5564{ 5636{
5565 pointer x = oblist_add_by_name (SCHEME_A_ name); 5637 pointer x = oblist_add_by_name (SCHEME_A_ name);
5566 set_typeflag (x, typeflag (x) | T_SYNTAX); 5638 set_typeflag (x, typeflag (x) | T_SYNTAX);
5567} 5639}
5568 5640
5569static void 5641ecb_cold static void
5570assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5642assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5571{ 5643{
5572 pointer x = mk_symbol (SCHEME_A_ name); 5644 pointer x = mk_symbol (SCHEME_A_ name);
5573 pointer y = mk_proc (SCHEME_A_ op); 5645 pointer y = mk_proc (SCHEME_A_ op);
5574 new_slot_in_env (SCHEME_A_ x, y); 5646 new_slot_in_env (SCHEME_A_ x, y);
… …
5582 ivalue_unchecked (y) = op; 5654 ivalue_unchecked (y) = op;
5583 return y; 5655 return y;
5584} 5656}
5585 5657
5586/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5658/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5587static int 5659ecb_hot static int
5588syntaxnum (pointer p) 5660syntaxnum (pointer p)
5589{ 5661{
5590 const char *s = strvalue (p); 5662 const char *s = strvalue (p);
5591 5663
5592 switch (strlength (p)) 5664 switch (strlength (p))
… …
5673scheme_init (SCHEME_P) 5745scheme_init (SCHEME_P)
5674{ 5746{
5675 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5747 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5676 pointer x; 5748 pointer x;
5677 5749
5750 /* this memset is not strictly correct, as we assume (intcache)
5751 * that memset 0 will also set pointers to 0, but memset does
5752 * of course not guarantee that. screw such systems.
5753 */
5678 memset (SCHEME_V, 0, sizeof (*SCHEME_V));//TODO !iso c 5754 memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5679 5755
5680 num_set_fixnum (num_zero, 1); 5756 num_set_fixnum (num_zero, 1);
5681 num_set_ivalue (num_zero, 0); 5757 num_set_ivalue (num_zero, 0);
5682 num_set_fixnum (num_one, 1); 5758 num_set_fixnum (num_one, 1);
5683 num_set_ivalue (num_one, 1); 5759 num_set_ivalue (num_one, 1);
… …
5695 SCHEME_V->save_inport = NIL; 5771 SCHEME_V->save_inport = NIL;
5696 SCHEME_V->loadport = NIL; 5772 SCHEME_V->loadport = NIL;
5697 SCHEME_V->nesting = 0; 5773 SCHEME_V->nesting = 0;
5698 SCHEME_V->interactive_repl = 0; 5774 SCHEME_V->interactive_repl = 0;
5699 5775
5700 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 5776 if (!alloc_cellseg (SCHEME_A))
5701 { 5777 {
5702#if USE_ERROR_CHECKING 5778#if USE_ERROR_CHECKING
5703 SCHEME_V->no_memory = 1; 5779 SCHEME_V->no_memory = 1;
5704 return 0; 5780 return 0;
5705#endif 5781#endif
5706 } 5782 }
5707 5783
5708 SCHEME_V->gc_verbose = 0; 5784 SCHEME_V->gc_verbose = 0;
5709 dump_stack_initialize (SCHEME_A); 5785 dump_stack_initialize (SCHEME_A);
5710 SCHEME_V->code = NIL; 5786 SCHEME_V->code = NIL;
5711 SCHEME_V->args = NIL; 5787 SCHEME_V->args = NIL;
5712 SCHEME_V->envir = NIL; 5788 SCHEME_V->envir = NIL;
5789 SCHEME_V->value = NIL;
5713 SCHEME_V->tracing = 0; 5790 SCHEME_V->tracing = 0;
5714 5791
5715 /* init NIL */ 5792 /* init NIL */
5716 set_typeflag (NIL, T_ATOM | T_MARK); 5793 set_typeflag (NIL, T_ATOM | T_MARK);
5717 set_car (NIL, NIL); 5794 set_car (NIL, NIL);
… …
5773 5850
5774 return !SCHEME_V->no_memory; 5851 return !SCHEME_V->no_memory;
5775} 5852}
5776 5853
5777#if USE_PORTS 5854#if USE_PORTS
5778void 5855ecb_cold void
5779scheme_set_input_port_file (SCHEME_P_ int fin) 5856scheme_set_input_port_file (SCHEME_P_ int fin)
5780{ 5857{
5781 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 5858 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5782} 5859}
5783 5860
5784void 5861ecb_cold void
5785scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 5862scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5786{ 5863{
5787 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 5864 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5788} 5865}
5789 5866
5790void 5867ecb_cold void
5791scheme_set_output_port_file (SCHEME_P_ int fout) 5868scheme_set_output_port_file (SCHEME_P_ int fout)
5792{ 5869{
5793 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 5870 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5794} 5871}
5795 5872
5796void 5873ecb_cold void
5797scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 5874scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5798{ 5875{
5799 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 5876 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5800} 5877}
5801#endif 5878#endif
5802 5879
5803void 5880ecb_cold void
5804scheme_set_external_data (SCHEME_P_ void *p) 5881scheme_set_external_data (SCHEME_P_ void *p)
5805{ 5882{
5806 SCHEME_V->ext_data = p; 5883 SCHEME_V->ext_data = p;
5807} 5884}
5808 5885
… …
5840 SCHEME_V->loadport = NIL; 5917 SCHEME_V->loadport = NIL;
5841 SCHEME_V->gc_verbose = 0; 5918 SCHEME_V->gc_verbose = 0;
5842 gc (SCHEME_A_ NIL, NIL); 5919 gc (SCHEME_A_ NIL, NIL);
5843 5920
5844 for (i = 0; i <= SCHEME_V->last_cell_seg; i++) 5921 for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5845 free (SCHEME_V->alloc_seg[i]); 5922 free (SCHEME_V->cell_seg[i]);
5846 5923
5847#if SHOW_ERROR_LINE 5924#if SHOW_ERROR_LINE
5848 for (i = 0; i <= SCHEME_V->file_i; i++) 5925 for (i = 0; i <= SCHEME_V->file_i; i++)
5849 {
5850 if (SCHEME_V->load_stack[i].kind & port_file) 5926 if (SCHEME_V->load_stack[i].kind & port_file)
5851 { 5927 {
5852 fname = SCHEME_V->load_stack[i].rep.stdio.filename; 5928 fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5853 5929
5854 if (fname) 5930 if (fname)
5855 free (fname); 5931 free (fname);
5856 } 5932 }
5857 }
5858#endif 5933#endif
5859} 5934}
5860 5935
5861void 5936ecb_cold void
5862scheme_load_file (SCHEME_P_ int fin) 5937scheme_load_file (SCHEME_P_ int fin)
5863{ 5938{
5864 scheme_load_named_file (SCHEME_A_ fin, 0); 5939 scheme_load_named_file (SCHEME_A_ fin, 0);
5865} 5940}
5866 5941
5867void 5942ecb_cold void
5868scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 5943scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5869{ 5944{
5870 dump_stack_reset (SCHEME_A); 5945 dump_stack_reset (SCHEME_A);
5871 SCHEME_V->envir = SCHEME_V->global_env; 5946 SCHEME_V->envir = SCHEME_V->global_env;
5872 SCHEME_V->file_i = 0; 5947 SCHEME_V->file_i = 0;
5873 SCHEME_V->load_stack[0].unget = -1; 5948 SCHEME_V->load_stack[0].unget = -1;
5874 SCHEME_V->load_stack[0].kind = port_input | port_file; 5949 SCHEME_V->load_stack[0].kind = port_input | port_file;
5875 SCHEME_V->load_stack[0].rep.stdio.file = fin; 5950 SCHEME_V->load_stack[0].rep.stdio.file = fin;
5876#if USE_PORTS
5877 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 5951 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5878#endif
5879 SCHEME_V->retcode = 0; 5952 SCHEME_V->retcode = 0;
5880 5953
5881#if USE_PORTS
5882 if (fin == STDIN_FILENO) 5954 if (fin == STDIN_FILENO)
5883 SCHEME_V->interactive_repl = 1; 5955 SCHEME_V->interactive_repl = 1;
5884#endif
5885 5956
5886#if USE_PORTS 5957#if USE_PORTS
5887#if SHOW_ERROR_LINE 5958#if SHOW_ERROR_LINE
5888 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0; 5959 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5889 5960
… …
5893#endif 5964#endif
5894 5965
5895 SCHEME_V->inport = SCHEME_V->loadport; 5966 SCHEME_V->inport = SCHEME_V->loadport;
5896 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 5967 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5897 Eval_Cycle (SCHEME_A_ OP_T0LVL); 5968 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5969
5898 set_typeflag (SCHEME_V->loadport, T_ATOM); 5970 set_typeflag (SCHEME_V->loadport, T_ATOM);
5899 5971
5900 if (SCHEME_V->retcode == 0) 5972 if (SCHEME_V->retcode == 0)
5901 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5973 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5902} 5974}
5903 5975
5904void 5976ecb_cold void
5905scheme_load_string (SCHEME_P_ const char *cmd) 5977scheme_load_string (SCHEME_P_ const char *cmd)
5906{ 5978{
5979#if USE_PORTs
5907 dump_stack_reset (SCHEME_A); 5980 dump_stack_reset (SCHEME_A);
5908 SCHEME_V->envir = SCHEME_V->global_env; 5981 SCHEME_V->envir = SCHEME_V->global_env;
5909 SCHEME_V->file_i = 0; 5982 SCHEME_V->file_i = 0;
5910 SCHEME_V->load_stack[0].kind = port_input | port_string; 5983 SCHEME_V->load_stack[0].kind = port_input | port_string;
5911 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ 5984 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5912 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); 5985 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5913 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; 5986 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5914#if USE_PORTS
5915 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 5987 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5916#endif
5917 SCHEME_V->retcode = 0; 5988 SCHEME_V->retcode = 0;
5918 SCHEME_V->interactive_repl = 0; 5989 SCHEME_V->interactive_repl = 0;
5919 SCHEME_V->inport = SCHEME_V->loadport; 5990 SCHEME_V->inport = SCHEME_V->loadport;
5920 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 5991 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5921 Eval_Cycle (SCHEME_A_ OP_T0LVL); 5992 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5922 set_typeflag (SCHEME_V->loadport, T_ATOM); 5993 set_typeflag (SCHEME_V->loadport, T_ATOM);
5923 5994
5924 if (SCHEME_V->retcode == 0) 5995 if (SCHEME_V->retcode == 0)
5925 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5996 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5997#else
5998 abort ();
5999#endif
5926} 6000}
5927 6001
5928void 6002ecb_cold void
5929scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 6003scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5930{ 6004{
5931 pointer x; 6005 pointer x;
5932 6006
5933 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 6007 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5938 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 6012 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5939} 6013}
5940 6014
5941#if !STANDALONE 6015#if !STANDALONE
5942 6016
5943void 6017ecb_cold void
5944scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 6018scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5945{ 6019{
5946 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 6020 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5947} 6021}
5948 6022
5949void 6023ecb_cold void
5950scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 6024scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5951{ 6025{
5952 int i; 6026 int i;
5953 6027
5954 for (i = 0; i < count; i++) 6028 for (i = 0; i < count; i++)
5955 scheme_register_foreign_func (SCHEME_A_ list + i); 6029 scheme_register_foreign_func (SCHEME_A_ list + i);
5956} 6030}
5957 6031
5958pointer 6032ecb_cold pointer
5959scheme_apply0 (SCHEME_P_ const char *procname) 6033scheme_apply0 (SCHEME_P_ const char *procname)
5960{ 6034{
5961 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 6035 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5962} 6036}
5963 6037
5964void 6038ecb_cold void
5965save_from_C_call (SCHEME_P) 6039save_from_C_call (SCHEME_P)
5966{ 6040{
5967 pointer saved_data = cons (car (S_SINK), 6041 pointer saved_data = cons (car (S_SINK),
5968 cons (SCHEME_V->envir, 6042 cons (SCHEME_V->envir,
5969 SCHEME_V->dump)); 6043 SCHEME_V->dump));
… …
5973 /* Truncate the dump stack so TS will return here when done, not 6047 /* Truncate the dump stack so TS will return here when done, not
5974 directly resume pre-C-call operations. */ 6048 directly resume pre-C-call operations. */
5975 dump_stack_reset (SCHEME_A); 6049 dump_stack_reset (SCHEME_A);
5976} 6050}
5977 6051
5978void 6052ecb_cold void
5979restore_from_C_call (SCHEME_P) 6053restore_from_C_call (SCHEME_P)
5980{ 6054{
5981 set_car (S_SINK, caar (SCHEME_V->c_nest)); 6055 set_car (S_SINK, caar (SCHEME_V->c_nest));
5982 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 6056 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5983 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 6057 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5984 /* Pop */ 6058 /* Pop */
5985 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 6059 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5986} 6060}
5987 6061
5988/* "func" and "args" are assumed to be already eval'ed. */ 6062/* "func" and "args" are assumed to be already eval'ed. */
5989pointer 6063ecb_cold pointer
5990scheme_call (SCHEME_P_ pointer func, pointer args) 6064scheme_call (SCHEME_P_ pointer func, pointer args)
5991{ 6065{
5992 int old_repl = SCHEME_V->interactive_repl; 6066 int old_repl = SCHEME_V->interactive_repl;
5993 6067
5994 SCHEME_V->interactive_repl = 0; 6068 SCHEME_V->interactive_repl = 0;
… …
6001 SCHEME_V->interactive_repl = old_repl; 6075 SCHEME_V->interactive_repl = old_repl;
6002 restore_from_C_call (SCHEME_A); 6076 restore_from_C_call (SCHEME_A);
6003 return SCHEME_V->value; 6077 return SCHEME_V->value;
6004} 6078}
6005 6079
6006pointer 6080ecb_cold pointer
6007scheme_eval (SCHEME_P_ pointer obj) 6081scheme_eval (SCHEME_P_ pointer obj)
6008{ 6082{
6009 int old_repl = SCHEME_V->interactive_repl; 6083 int old_repl = SCHEME_V->interactive_repl;
6010 6084
6011 SCHEME_V->interactive_repl = 0; 6085 SCHEME_V->interactive_repl = 0;
… …
6023 6097
6024/* ========== Main ========== */ 6098/* ========== Main ========== */
6025 6099
6026#if STANDALONE 6100#if STANDALONE
6027 6101
6028int 6102ecb_cold int
6029main (int argc, char **argv) 6103main (int argc, char **argv)
6030{ 6104{
6031# if USE_MULTIPLICITY 6105# if USE_MULTIPLICITY
6032 scheme ssc; 6106 scheme ssc;
6033 scheme *const SCHEME_V = &ssc; 6107 scheme *const SCHEME_V = &ssc;
… …
6035# endif 6109# endif
6036 int fin; 6110 int fin;
6037 char *file_name = InitFile; 6111 char *file_name = InitFile;
6038 int retcode; 6112 int retcode;
6039 int isfile = 1; 6113 int isfile = 1;
6114#if EXPERIMENT
6040 system ("ps v $PPID");//D 6115 system ("ps v $PPID");
6116#endif
6041 6117
6042 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6118 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6043 { 6119 {
6044 xwrstr ("Usage: tinyscheme -?\n"); 6120 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6045 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6121 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6046 xwrstr ("followed by\n"); 6122 putstr (SCHEME_A_ "followed by\n");
6047 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6123 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6048 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6124 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6049 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6125 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6050 xwrstr ("Use - as filename for stdin.\n"); 6126 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6051 return 1; 6127 return 1;
6052 } 6128 }
6053 6129
6054 if (!scheme_init (SCHEME_A)) 6130 if (!scheme_init (SCHEME_A))
6055 { 6131 {
6056 xwrstr ("Could not initialize!\n"); 6132 putstr (SCHEME_A_ "Could not initialize!\n");
6057 return 2; 6133 return 2;
6058 } 6134 }
6059 6135
6060# if USE_PORTS 6136# if USE_PORTS
6061 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6137 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6074 } 6150 }
6075#endif 6151#endif
6076 6152
6077 do 6153 do
6078 { 6154 {
6079#if USE_PORTS
6080 if (strcmp (file_name, "-") == 0) 6155 if (strcmp (file_name, "-") == 0)
6081 fin = STDIN_FILENO; 6156 fin = STDIN_FILENO;
6082 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) 6157 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
6083 { 6158 {
6084 pointer args = NIL; 6159 pointer args = NIL;
… …
6102 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args); 6177 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
6103 6178
6104 } 6179 }
6105 else 6180 else
6106 fin = open (file_name, O_RDONLY); 6181 fin = open (file_name, O_RDONLY);
6107#endif
6108 6182
6109 if (isfile && fin < 0) 6183 if (isfile && fin < 0)
6110 { 6184 {
6111 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6185 putstr (SCHEME_A_ "Could not open file ");
6186 putstr (SCHEME_A_ file_name);
6187 putcharacter (SCHEME_A_ '\n');
6112 } 6188 }
6113 else 6189 else
6114 { 6190 {
6115 if (isfile) 6191 if (isfile)
6116 scheme_load_named_file (SCHEME_A_ fin, file_name); 6192 scheme_load_named_file (SCHEME_A_ fin, file_name);
6117 else 6193 else
6118 scheme_load_string (SCHEME_A_ file_name); 6194 scheme_load_string (SCHEME_A_ file_name);
6119 6195
6120#if USE_PORTS
6121 if (!isfile || fin != STDIN_FILENO) 6196 if (!isfile || fin != STDIN_FILENO)
6122 { 6197 {
6123 if (SCHEME_V->retcode != 0) 6198 if (SCHEME_V->retcode != 0)
6124 { 6199 {
6125 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6200 putstr (SCHEME_A_ "Errors encountered reading ");
6201 putstr (SCHEME_A_ file_name);
6202 putcharacter (SCHEME_A_ '\n');
6126 } 6203 }
6127 6204
6128 if (isfile) 6205 if (isfile)
6129 close (fin); 6206 close (fin);
6130 } 6207 }
6131#endif
6132 } 6208 }
6133 6209
6134 file_name = *argv++; 6210 file_name = *argv++;
6135 } 6211 }
6136 while (file_name != 0); 6212 while (file_name != 0);

Diff Legend

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