ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/microscheme/scheme.c
(Generate patch)

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.44 by root, Mon Nov 30 06:49:11 2015 UTC vs.
Revision 1.60 by root, Wed Dec 2 02:59:36 2015 UTC

… …
18 * 18 *
19 */ 19 */
20 20
21#define EXPERIMENT 1 21#define EXPERIMENT 1
22 22
23#if 1
23#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ 24#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
24#include "malloc.c" 25#include "malloc.c"
26#endif
25 27
26#define SCHEME_SOURCE 28#define SCHEME_SOURCE
27#include "scheme-private.h" 29#include "scheme-private.h"
28#ifndef WIN32 30#ifndef WIN32
29# include <unistd.h> 31# include <unistd.h>
… …
79 81
80#define BACKQUOTE '`' 82#define BACKQUOTE '`'
81#define WHITESPACE " \t\r\n\v\f" 83#define WHITESPACE " \t\r\n\v\f"
82#define DELIMITERS "()\";" WHITESPACE 84#define DELIMITERS "()\";" WHITESPACE
83 85
84#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 86#define NIL POINTER (&SCHEME_V->xNIL)
85#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 87#define S_T POINTER (&SCHEME_V->xT)
86#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 88#define S_F POINTER (&SCHEME_V->xF)
87#define S_SINK (&SCHEME_V->xsink) 89#define S_SINK POINTER (&SCHEME_V->xsink)
88#define S_EOF (&SCHEME_V->xEOF_OBJ) 90#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
89 91
90#if !USE_MULTIPLICITY 92#if !USE_MULTIPLICITY
91static scheme sc; 93static scheme sc;
92#endif 94#endif
93 95
94static void 96ecb_cold static void
95xbase (char *s, long n, int base) 97xbase (char *s, long n, int base)
96{ 98{
97 if (n < 0) 99 if (n < 0)
98 { 100 {
99 *s++ = '-'; 101 *s++ = '-';
… …
101 } 103 }
102 104
103 char *p = s; 105 char *p = s;
104 106
105 do { 107 do {
106 *p++ = '0' + n % base; 108 *p++ = "0123456789abcdef"[n % base];
107 n /= base; 109 n /= base;
108 } while (n); 110 } while (n);
109 111
110 *p-- = 0; 112 *p-- = 0;
111 113
… …
114 char x = *s; *s = *p; *p = x; 116 char x = *s; *s = *p; *p = x;
115 --p; ++s; 117 --p; ++s;
116 } 118 }
117} 119}
118 120
119static void 121ecb_cold static void
120xnum (char *s, long n) 122xnum (char *s, long n)
121{ 123{
122 xbase (s, n, 10); 124 xbase (s, n, 10);
123} 125}
124 126
125static void 127ecb_cold static void
126xwrstr (const char *s) 128putnum (SCHEME_P_ long n)
127{
128 write (1, s, strlen (s));
129}
130
131static void
132xwrnum (long n)
133{ 129{
134 char buf[64]; 130 char buf[64];
135 131
136 xnum (buf, n); 132 xnum (buf, n);
137 xwrstr (buf); 133 putstr (SCHEME_A_ buf);
138} 134}
139 135
140static char 136ecb_cold static char
141xtoupper (char c) 137xtoupper (char c)
142{ 138{
143 if (c >= 'a' && c <= 'z') 139 if (c >= 'a' && c <= 'z')
144 c -= 'a' - 'A'; 140 c -= 'a' - 'A';
145 141
146 return c; 142 return c;
147} 143}
148 144
149static char 145ecb_cold static char
150xtolower (char c) 146xtolower (char c)
151{ 147{
152 if (c >= 'A' && c <= 'Z') 148 if (c >= 'A' && c <= 'Z')
153 c += 'a' - 'A'; 149 c += 'a' - 'A';
154 150
155 return c; 151 return c;
156} 152}
157 153
158static int 154ecb_cold static int
159xisdigit (char c) 155xisdigit (char c)
160{ 156{
161 return c >= '0' && c <= '9'; 157 return c >= '0' && c <= '9';
162} 158}
163 159
164#define toupper(c) xtoupper (c) 160#define toupper(c) xtoupper (c)
165#define tolower(c) xtolower (c) 161#define tolower(c) xtolower (c)
166#define isdigit(c) xisdigit (c) 162#define isdigit(c) xisdigit (c)
167 163
168#if USE_IGNORECASE 164#if USE_IGNORECASE
169static const char * 165ecb_cold static const char *
170xstrlwr (char *s) 166xstrlwr (char *s)
171{ 167{
172 const char *p = s; 168 const char *p = s;
173 169
174 while (*s) 170 while (*s)
… …
194 190
195#ifndef InitFile 191#ifndef InitFile
196# define InitFile "init.scm" 192# define InitFile "init.scm"
197#endif 193#endif
198 194
199#ifndef FIRST_CELLSEGS
200# define FIRST_CELLSEGS 3
201#endif
202
203enum scheme_types 195enum scheme_types
204{ 196{
205 T_INTEGER, 197 T_INTEGER,
198 T_CHARACTER,
206 T_REAL, 199 T_REAL,
207 T_STRING, 200 T_STRING,
208 T_SYMBOL, 201 T_SYMBOL,
209 T_PROC, 202 T_PROC,
210 T_PAIR, /* also used for free cells */ 203 T_PAIR, /* also used for free cells */
211 T_CLOSURE, 204 T_CLOSURE,
205 T_MACRO,
212 T_CONTINUATION, 206 T_CONTINUATION,
213 T_FOREIGN, 207 T_FOREIGN,
214 T_CHARACTER,
215 T_PORT, 208 T_PORT,
216 T_VECTOR, 209 T_VECTOR,
217 T_MACRO,
218 T_PROMISE, 210 T_PROMISE,
219 T_ENVIRONMENT, 211 T_ENVIRONMENT,
220 /* one more... */ 212 /* one more... */
221 T_NUM_SYSTEM_TYPES 213 T_NUM_SYSTEM_TYPES
222}; 214};
… …
258static num num_op (enum num_op op, num a, num b); 250static num num_op (enum num_op op, num a, num b);
259static num num_intdiv (num a, num b); 251static num num_intdiv (num a, num b);
260static num num_rem (num a, num b); 252static num num_rem (num a, num b);
261static num num_mod (num a, num b); 253static num num_mod (num a, num b);
262 254
263#if USE_MATH
264static double round_per_R5RS (double x);
265#endif
266static int is_zero_rvalue (RVALUE x); 255static int is_zero_rvalue (RVALUE x);
267 256
268static num num_zero; 257static num num_zero;
269static num num_one; 258static num num_one;
270 259
260/* convert "pointer" to cell* / cell* to pointer */
261#define CELL(p) ((struct cell *)(p) + 0)
262#define POINTER(c) ((void *)((c) - 0))
263
271/* macros for cell operations */ 264/* macros for cell operations */
272#define typeflag(p) ((p)->flag + 0) 265#define typeflag(p) (CELL(p)->flag + 0)
273#define set_typeflag(p,v) ((p)->flag = (v)) 266#define set_typeflag(p,v) (CELL(p)->flag = (v))
274#define type(p) (typeflag (p) & T_MASKTYPE) 267#define type(p) (typeflag (p) & T_MASKTYPE)
275 268
276INTERFACE int 269INTERFACE int
277is_string (pointer p) 270is_string (pointer p)
278{ 271{
279 return type (p) == T_STRING; 272 return type (p) == T_STRING;
280} 273}
281 274
282#define strvalue(p) ((p)->object.string.svalue) 275#define strvalue(p) (CELL(p)->object.string.svalue)
283#define strlength(p) ((p)->object.string.length) 276#define strlength(p) (CELL(p)->object.string.length)
284 277
285INTERFACE int 278INTERFACE int
286is_vector (pointer p) 279is_vector (pointer p)
287{ 280{
288 return type (p) == T_VECTOR; 281 return type (p) == T_VECTOR;
289} 282}
290 283
291#define vecvalue(p) ((p)->object.vector.vvalue) 284#define vecvalue(p) (CELL(p)->object.vector.vvalue)
292#define veclength(p) ((p)->object.vector.length) 285#define veclength(p) (CELL(p)->object.vector.length)
293INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); 286INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
294INTERFACE pointer vector_get (pointer vec, uint32_t ielem); 287INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
295INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); 288INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
296 289
297INTERFACE int 290INTERFACE int
… …
323string_value (pointer p) 316string_value (pointer p)
324{ 317{
325 return strvalue (p); 318 return strvalue (p);
326} 319}
327 320
328#define ivalue_unchecked(p) (p)->object.ivalue 321#define ivalue_unchecked(p) CELL(p)->object.ivalue
329#define set_ivalue(p,v) (p)->object.ivalue = (v) 322#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
330 323
331#if USE_REAL 324#if USE_REAL
332#define rvalue_unchecked(p) (p)->object.rvalue 325#define rvalue_unchecked(p) CELL(p)->object.rvalue
333#define set_rvalue(p,v) (p)->object.rvalue = (v) 326#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
334#else 327#else
335#define rvalue_unchecked(p) (p)->object.ivalue 328#define rvalue_unchecked(p) CELL(p)->object.ivalue
336#define set_rvalue(p,v) (p)->object.ivalue = (v) 329#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
337#endif 330#endif
338 331
339INTERFACE long 332INTERFACE long
340charvalue (pointer p) 333charvalue (pointer p)
341{ 334{
342 return ivalue_unchecked (p); 335 return ivalue_unchecked (p);
343} 336}
344 337
338#define port(p) CELL(p)->object.port
339#define set_port(p,v) port(p) = (v)
345INTERFACE int 340INTERFACE int
346is_port (pointer p) 341is_port (pointer p)
347{ 342{
348 return type (p) == T_PORT; 343 return type (p) == T_PORT;
349} 344}
350 345
351INTERFACE int 346INTERFACE int
352is_inport (pointer p) 347is_inport (pointer p)
353{ 348{
354 return is_port (p) && p->object.port->kind & port_input; 349 return is_port (p) && port (p)->kind & port_input;
355} 350}
356 351
357INTERFACE int 352INTERFACE int
358is_outport (pointer p) 353is_outport (pointer p)
359{ 354{
360 return is_port (p) && p->object.port->kind & port_output; 355 return is_port (p) && port (p)->kind & port_output;
361} 356}
362 357
363INTERFACE int 358INTERFACE int
364is_pair (pointer p) 359is_pair (pointer p)
365{ 360{
366 return type (p) == T_PAIR; 361 return type (p) == T_PAIR;
367} 362}
368 363
369#define car(p) ((p)->object.cons.car + 0) 364#define car(p) (POINTER (CELL(p)->object.cons.car))
370#define cdr(p) ((p)->object.cons.cdr + 0) 365#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
371 366
372static pointer caar (pointer p) { return car (car (p)); } 367static pointer caar (pointer p) { return car (car (p)); }
373static pointer cadr (pointer p) { return car (cdr (p)); } 368static pointer cadr (pointer p) { return car (cdr (p)); }
374static pointer cdar (pointer p) { return cdr (car (p)); } 369static pointer cdar (pointer p) { return cdr (car (p)); }
375static pointer cddr (pointer p) { return cdr (cdr (p)); } 370static pointer cddr (pointer p) { return cdr (cdr (p)); }
… …
379static pointer cdaar (pointer p) { return cdr (car (car (p))); } 374static pointer cdaar (pointer p) { return cdr (car (car (p))); }
380 375
381INTERFACE void 376INTERFACE void
382set_car (pointer p, pointer q) 377set_car (pointer p, pointer q)
383{ 378{
384 p->object.cons.car = q; 379 CELL(p)->object.cons.car = CELL (q);
385} 380}
386 381
387INTERFACE void 382INTERFACE void
388set_cdr (pointer p, pointer q) 383set_cdr (pointer p, pointer q)
389{ 384{
390 p->object.cons.cdr = q; 385 CELL(p)->object.cons.cdr = CELL (q);
391} 386}
392 387
393INTERFACE pointer 388INTERFACE pointer
394pair_car (pointer p) 389pair_car (pointer p)
395{ 390{
… …
413{ 408{
414 return strvalue (p); 409 return strvalue (p);
415} 410}
416 411
417#if USE_PLIST 412#if USE_PLIST
413#error plists are broken because symbols are no longer pairs
418#define symprop(p) cdr(p) 414#define symprop(p) cdr(p)
419SCHEME_EXPORT int 415SCHEME_EXPORT int
420hasprop (pointer p) 416hasprop (pointer p)
421{ 417{
422 return typeflag (p) & T_SYMBOL; 418 return typeflag (p) & T_SYMBOL;
… …
524 proper list: length 520 proper list: length
525 circular list: -1 521 circular list: -1
526 not even a pair: -2 522 not even a pair: -2
527 dotted list: -2 minus length before dot 523 dotted list: -2 minus length before dot
528*/ 524*/
529INTERFACE int 525ecb_hot INTERFACE int
530list_length (SCHEME_P_ pointer a) 526list_length (SCHEME_P_ pointer a)
531{ 527{
532 int i = 0; 528 int i = 0;
533 pointer slow, fast; 529 pointer slow, fast;
534 530
… …
640 "gs", 636 "gs",
641 "rs", 637 "rs",
642 "us" 638 "us"
643}; 639};
644 640
645static int 641ecb_cold static int
646is_ascii_name (const char *name, int *pc) 642is_ascii_name (const char *name, int *pc)
647{ 643{
648 int i; 644 int i;
649 645
650 for (i = 0; i < 32; i++) 646 for (i = 0; i < 32; i++)
… …
669 665
670static int file_push (SCHEME_P_ const char *fname); 666static int file_push (SCHEME_P_ const char *fname);
671static void file_pop (SCHEME_P); 667static void file_pop (SCHEME_P);
672static int file_interactive (SCHEME_P); 668static int file_interactive (SCHEME_P);
673ecb_inline int is_one_of (const char *s, int c); 669ecb_inline int is_one_of (const char *s, int c);
674static int alloc_cellseg (SCHEME_P_ int n); 670static int alloc_cellseg (SCHEME_P);
675ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 671ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
676static void finalize_cell (SCHEME_P_ pointer a); 672static void finalize_cell (SCHEME_P_ pointer a);
677static int count_consecutive_cells (pointer x, int needed); 673static int count_consecutive_cells (pointer x, int needed);
678static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 674static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
679static pointer mk_number (SCHEME_P_ const num n); 675static pointer mk_number (SCHEME_P_ const num n);
… …
873 } 869 }
874 870
875 return ret; 871 return ret;
876} 872}
877 873
878#if USE_MATH
879
880/* Round to nearest. Round to even if midway */
881static double
882round_per_R5RS (double x)
883{
884 double fl = floor (x);
885 double ce = ceil (x);
886 double dfl = x - fl;
887 double dce = ce - x;
888
889 if (dfl > dce)
890 return ce;
891 else if (dfl < dce)
892 return fl;
893 else
894 {
895 if (fmod (fl, 2) == 0) /* I imagine this holds */
896 return fl;
897 else
898 return ce;
899 }
900}
901#endif
902
903static int 874static int
904is_zero_rvalue (RVALUE x) 875is_zero_rvalue (RVALUE x)
905{ 876{
906 return x == 0; 877 return x == 0;
907#if 0 878#if 0
… …
912#endif 883#endif
913#endif 884#endif
914} 885}
915 886
916/* allocate new cell segment */ 887/* allocate new cell segment */
917static int 888ecb_cold static int
918alloc_cellseg (SCHEME_P_ int n) 889alloc_cellseg (SCHEME_P)
919{ 890{
920 pointer newp; 891 struct cell *newp;
921 pointer last; 892 struct cell *last;
922 pointer p; 893 struct cell *p;
923 char *cp; 894 char *cp;
924 long i; 895 long i;
925 int k; 896 int k;
926 897
927 static int segsize = CELL_SEGSIZE >> 1; 898 static int segsize = CELL_SEGSIZE >> 1;
928 segsize <<= 1; 899 segsize <<= 1;
929 900
930 for (k = 0; k < n; k++)
931 {
932 if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
933 return k;
934
935 cp = malloc (segsize * sizeof (struct cell)); 901 cp = malloc (segsize * sizeof (struct cell));
936 902
937 if (!cp && USE_ERROR_CHECKING) 903 if (!cp && USE_ERROR_CHECKING)
938 return k; 904 return k;
939 905
940 i = ++SCHEME_V->last_cell_seg; 906 i = ++SCHEME_V->last_cell_seg;
941 SCHEME_V->alloc_seg[i] = cp; 907 SCHEME_V->alloc_seg[i] = cp;
942 908
943 newp = (pointer)cp; 909 newp = (struct cell *)cp;
944 SCHEME_V->cell_seg[i] = newp; 910 SCHEME_V->cell_seg[i] = newp;
945 SCHEME_V->cell_segsize[i] = segsize; 911 SCHEME_V->cell_segsize[i] = segsize;
946 SCHEME_V->fcells += segsize; 912 SCHEME_V->fcells += segsize;
947 last = newp + segsize - 1; 913 last = newp + segsize - 1;
948 914
949 for (p = newp; p <= last; p++) 915 for (p = newp; p <= last; p++)
950 { 916 {
917 pointer cp = POINTER (p);
951 set_typeflag (p, T_PAIR); 918 set_typeflag (cp, T_PAIR);
952 set_car (p, NIL); 919 set_car (cp, NIL);
953 set_cdr (p, p + 1); 920 set_cdr (cp, POINTER (p + 1));
954 } 921 }
955 922
956 set_cdr (last, SCHEME_V->free_cell); 923 set_cdr (POINTER (last), SCHEME_V->free_cell);
957 SCHEME_V->free_cell = newp; 924 SCHEME_V->free_cell = POINTER (newp);
958 }
959 925
960 return n; 926 return 1;
961} 927}
962 928
963/* get new cell. parameter a, b is marked by gc. */ 929/* get new cell. parameter a, b is marked by gc. */
964ecb_inline pointer 930ecb_inline pointer
965get_cell_x (SCHEME_P_ pointer a, pointer b) 931get_cell_x (SCHEME_P_ pointer a, pointer b)
… …
969 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 935 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
970 return S_SINK; 936 return S_SINK;
971 937
972 if (SCHEME_V->free_cell == NIL) 938 if (SCHEME_V->free_cell == NIL)
973 { 939 {
974 const int min_to_be_recovered = SCHEME_V->last_cell_seg < 128 ? 128 * 8 : SCHEME_V->last_cell_seg * 8; 940 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1;
975 941
976 gc (SCHEME_A_ a, b); 942 gc (SCHEME_A_ a, b);
977 943
978 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 944 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
979 { 945 {
980 /* if only a few recovered, get more to avoid fruitless gc's */ 946 /* if only a few recovered, get more to avoid fruitless gc's */
981 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 947 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
982 { 948 {
983#if USE_ERROR_CHECKING 949#if USE_ERROR_CHECKING
984 SCHEME_V->no_memory = 1; 950 SCHEME_V->no_memory = 1;
985 return S_SINK; 951 return S_SINK;
986#endif 952#endif
… …
998 } 964 }
999} 965}
1000 966
1001/* To retain recent allocs before interpreter knows about them - 967/* To retain recent allocs before interpreter knows about them -
1002 Tehom */ 968 Tehom */
1003 969ecb_hot static void
1004static void
1005push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 970push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1006{ 971{
1007 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 972 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1008 973
1009 set_typeflag (holder, T_PAIR); 974 set_typeflag (holder, T_PAIR);
… …
1011 set_car (holder, recent); 976 set_car (holder, recent);
1012 set_cdr (holder, car (S_SINK)); 977 set_cdr (holder, car (S_SINK));
1013 set_car (S_SINK, holder); 978 set_car (S_SINK, holder);
1014} 979}
1015 980
1016static pointer 981ecb_hot static pointer
1017get_cell (SCHEME_P_ pointer a, pointer b) 982get_cell (SCHEME_P_ pointer a, pointer b)
1018{ 983{
1019 pointer cell = get_cell_x (SCHEME_A_ a, b); 984 pointer cell = get_cell_x (SCHEME_A_ a, b);
1020 985
1021 /* For right now, include "a" and "b" in "cell" so that gc doesn't 986 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1030} 995}
1031 996
1032static pointer 997static pointer
1033get_vector_object (SCHEME_P_ uint32_t len, pointer init) 998get_vector_object (SCHEME_P_ uint32_t len, pointer init)
1034{ 999{
1035 pointer v = get_cell_x (SCHEME_A_ 0, 0); 1000 pointer v = get_cell_x (SCHEME_A_ NIL, NIL);
1036 pointer *e = malloc (len * sizeof (pointer)); 1001 pointer *e = malloc (len * sizeof (pointer));
1037 1002
1038 if (!e && USE_ERROR_CHECKING) 1003 if (!e && USE_ERROR_CHECKING)
1039 return S_SINK; 1004 return S_SINK;
1040 1005
1041 /* Record it as a vector so that gc understands it. */ 1006 /* Record it as a vector so that gc understands it. */
1042 set_typeflag (v, T_VECTOR | T_ATOM); 1007 set_typeflag (v, T_VECTOR | T_ATOM);
1043 1008
1044 v->object.vector.vvalue = e; 1009 CELL(v)->object.vector.vvalue = e;
1045 v->object.vector.length = len; 1010 CELL(v)->object.vector.length = len;
1046 fill_vector (v, 0, init); 1011 fill_vector (v, 0, init);
1047 push_recent_alloc (SCHEME_A_ v, NIL); 1012 push_recent_alloc (SCHEME_A_ v, NIL);
1048 1013
1049 return v; 1014 return v;
1050} 1015}
… …
1059static void 1024static void
1060check_cell_alloced (pointer p, int expect_alloced) 1025check_cell_alloced (pointer p, int expect_alloced)
1061{ 1026{
1062 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ 1027 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1063 if (typeflag (p) & !expect_alloced) 1028 if (typeflag (p) & !expect_alloced)
1064 xwrstr ("Cell is already allocated!\n"); 1029 putstr (SCHEME_A_ "Cell is already allocated!\n");
1065 1030
1066 if (!(typeflag (p)) & expect_alloced) 1031 if (!(typeflag (p)) & expect_alloced)
1067 xwrstr ("Cell is not allocated!\n"); 1032 putstr (SCHEME_A_ "Cell is not allocated!\n");
1068} 1033}
1069 1034
1070static void 1035static void
1071check_range_alloced (pointer p, int n, int expect_alloced) 1036check_range_alloced (pointer p, int n, int expect_alloced)
1072{ 1037{
… …
1078#endif 1043#endif
1079 1044
1080/* Medium level cell allocation */ 1045/* Medium level cell allocation */
1081 1046
1082/* get new cons cell */ 1047/* get new cons cell */
1083pointer 1048ecb_hot pointer
1084xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1049xcons (SCHEME_P_ pointer a, pointer b, int immutable)
1085{ 1050{
1086 pointer x = get_cell (SCHEME_A_ a, b); 1051 pointer x = get_cell (SCHEME_A_ a, b);
1087 1052
1088 set_typeflag (x, T_PAIR); 1053 set_typeflag (x, T_PAIR);
… …
1094 set_cdr (x, b); 1059 set_cdr (x, b);
1095 1060
1096 return x; 1061 return x;
1097} 1062}
1098 1063
1099static pointer 1064ecb_cold static pointer
1100generate_symbol (SCHEME_P_ const char *name) 1065generate_symbol (SCHEME_P_ const char *name)
1101{ 1066{
1102 pointer x = mk_string (SCHEME_A_ name); 1067 pointer x = mk_string (SCHEME_A_ name);
1103 setimmutable (x); 1068 setimmutable (x);
1104 set_typeflag (x, T_SYMBOL | T_ATOM); 1069 set_typeflag (x, T_SYMBOL | T_ATOM);
… …
1119 hash = (hash ^ *p++) * 16777619; 1084 hash = (hash ^ *p++) * 16777619;
1120 1085
1121 return hash % table_size; 1086 return hash % table_size;
1122} 1087}
1123 1088
1124static pointer 1089ecb_cold static pointer
1125oblist_initial_value (SCHEME_P) 1090oblist_initial_value (SCHEME_P)
1126{ 1091{
1127 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1092 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1128} 1093}
1129 1094
1130/* returns the new symbol */ 1095/* returns the new symbol */
1131static pointer 1096ecb_cold static pointer
1132oblist_add_by_name (SCHEME_P_ const char *name) 1097oblist_add_by_name (SCHEME_P_ const char *name)
1133{ 1098{
1134 pointer x = generate_symbol (SCHEME_A_ name); 1099 pointer x = generate_symbol (SCHEME_A_ name);
1135 int location = hash_fn (name, veclength (SCHEME_V->oblist)); 1100 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1136 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); 1101 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1137 return x; 1102 return x;
1138} 1103}
1139 1104
1140ecb_inline pointer 1105ecb_cold static pointer
1141oblist_find_by_name (SCHEME_P_ const char *name) 1106oblist_find_by_name (SCHEME_P_ const char *name)
1142{ 1107{
1143 int location; 1108 int location;
1144 pointer x; 1109 pointer x;
1145 char *s; 1110 char *s;
… …
1156 } 1121 }
1157 1122
1158 return NIL; 1123 return NIL;
1159} 1124}
1160 1125
1161static pointer 1126ecb_cold static pointer
1162oblist_all_symbols (SCHEME_P) 1127oblist_all_symbols (SCHEME_P)
1163{ 1128{
1164 int i; 1129 int i;
1165 pointer x; 1130 pointer x;
1166 pointer ob_list = NIL; 1131 pointer ob_list = NIL;
… …
1172 return ob_list; 1137 return ob_list;
1173} 1138}
1174 1139
1175#else 1140#else
1176 1141
1177static pointer 1142ecb_cold static pointer
1178oblist_initial_value (SCHEME_P) 1143oblist_initial_value (SCHEME_P)
1179{ 1144{
1180 return NIL; 1145 return NIL;
1181} 1146}
1182 1147
1183ecb_inline pointer 1148ecb_cold static pointer
1184oblist_find_by_name (SCHEME_P_ const char *name) 1149oblist_find_by_name (SCHEME_P_ const char *name)
1185{ 1150{
1186 pointer x; 1151 pointer x;
1187 char *s; 1152 char *s;
1188 1153
… …
1197 1162
1198 return NIL; 1163 return NIL;
1199} 1164}
1200 1165
1201/* returns the new symbol */ 1166/* returns the new symbol */
1202static pointer 1167ecb_cold static pointer
1203oblist_add_by_name (SCHEME_P_ const char *name) 1168oblist_add_by_name (SCHEME_P_ const char *name)
1204{ 1169{
1205 pointer x = mk_string (SCHEME_A_ name); 1170 pointer x = generate_symbol (SCHEME_A_ name);
1206 set_typeflag (x, T_SYMBOL);
1207 setimmutable (x);
1208 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1171 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1209 return x; 1172 return x;
1210} 1173}
1211 1174
1212static pointer 1175ecb_cold static pointer
1213oblist_all_symbols (SCHEME_P) 1176oblist_all_symbols (SCHEME_P)
1214{ 1177{
1215 return SCHEME_V->oblist; 1178 return SCHEME_V->oblist;
1216} 1179}
1217 1180
1218#endif 1181#endif
1219 1182
1220#if USE_PORTS 1183#if USE_PORTS
1221static pointer 1184ecb_cold static pointer
1222mk_port (SCHEME_P_ port *p) 1185mk_port (SCHEME_P_ port *p)
1223{ 1186{
1224 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1187 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1225 1188
1226 set_typeflag (x, T_PORT | T_ATOM); 1189 set_typeflag (x, T_PORT | T_ATOM);
1227 x->object.port = p; 1190 set_port (x, p);
1228 1191
1229 return x; 1192 return x;
1230} 1193}
1231#endif 1194#endif
1232 1195
1233pointer 1196ecb_cold pointer
1234mk_foreign_func (SCHEME_P_ foreign_func f) 1197mk_foreign_func (SCHEME_P_ foreign_func f)
1235{ 1198{
1236 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1199 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1237 1200
1238 set_typeflag (x, (T_FOREIGN | T_ATOM)); 1201 set_typeflag (x, T_FOREIGN | T_ATOM);
1239 x->object.ff = f; 1202 CELL(x)->object.ff = f;
1240 1203
1241 return x; 1204 return x;
1242} 1205}
1243 1206
1244INTERFACE pointer 1207INTERFACE pointer
1245mk_character (SCHEME_P_ int c) 1208mk_character (SCHEME_P_ int c)
1246{ 1209{
1247 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1210 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1248 1211
1249 set_typeflag (x, (T_CHARACTER | T_ATOM)); 1212 set_typeflag (x, T_CHARACTER | T_ATOM);
1250 set_ivalue (x, c & 0xff); 1213 set_ivalue (x, c & 0xff);
1251 1214
1252 return x; 1215 return x;
1253} 1216}
1254 1217
1255/* get number atom (integer) */ 1218/* get number atom (integer) */
1256INTERFACE pointer 1219INTERFACE pointer
1257mk_integer (SCHEME_P_ long n) 1220mk_integer (SCHEME_P_ long n)
1258{ 1221{
1222 pointer p = 0;
1223 pointer *pp = &p;
1224
1225#if USE_INTCACHE
1226 if (n >= INTCACHE_MIN && n <= INTCACHE_MAX)
1227 pp = &SCHEME_V->intcache[n - INTCACHE_MIN];
1228#endif
1229
1230 if (!*pp)
1231 {
1259 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1232 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1260 1233
1261 set_typeflag (x, (T_INTEGER | T_ATOM)); 1234 set_typeflag (x, T_INTEGER | T_ATOM);
1235 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */
1262 set_ivalue (x, n); 1236 set_ivalue (x, n);
1263 1237
1238 *pp = x;
1239 }
1240
1264 return x; 1241 return *pp;
1265} 1242}
1266 1243
1267INTERFACE pointer 1244INTERFACE pointer
1268mk_real (SCHEME_P_ RVALUE n) 1245mk_real (SCHEME_P_ RVALUE n)
1269{ 1246{
1270#if USE_REAL 1247#if USE_REAL
1271 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1248 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1272 1249
1273 set_typeflag (x, (T_REAL | T_ATOM)); 1250 set_typeflag (x, T_REAL | T_ATOM);
1274 set_rvalue (x, n); 1251 set_rvalue (x, n);
1275 1252
1276 return x; 1253 return x;
1277#else 1254#else
1278 return mk_integer (SCHEME_A_ n); 1255 return mk_integer (SCHEME_A_ n);
… …
1389 x = oblist_add_by_name (SCHEME_A_ name); 1366 x = oblist_add_by_name (SCHEME_A_ name);
1390 1367
1391 return x; 1368 return x;
1392} 1369}
1393 1370
1394INTERFACE pointer 1371ecb_cold INTERFACE pointer
1395gensym (SCHEME_P) 1372gensym (SCHEME_P)
1396{ 1373{
1397 pointer x; 1374 pointer x;
1398 char name[40] = "gensym-"; 1375 char name[40] = "gensym-";
1399 xnum (name + 7, ++SCHEME_V->gensym_cnt); 1376 xnum (name + 7, ++SCHEME_V->gensym_cnt);
… …
1406{ 1383{
1407 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; 1384 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1408} 1385}
1409 1386
1410/* make symbol or number atom from string */ 1387/* make symbol or number atom from string */
1411static pointer 1388ecb_cold static pointer
1412mk_atom (SCHEME_P_ char *q) 1389mk_atom (SCHEME_P_ char *q)
1413{ 1390{
1414 char c, *p; 1391 char c, *p;
1415 int has_dec_point = 0; 1392 int has_dec_point = 0;
1416 int has_fp_exp = 0; 1393 int has_fp_exp = 0;
… …
1487 1464
1488 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1465 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1489} 1466}
1490 1467
1491/* make constant */ 1468/* make constant */
1492static pointer 1469ecb_cold static pointer
1493mk_sharp_const (SCHEME_P_ char *name) 1470mk_sharp_const (SCHEME_P_ char *name)
1494{ 1471{
1495 if (!strcmp (name, "t")) 1472 if (!strcmp (name, "t"))
1496 return S_T; 1473 return S_T;
1497 else if (!strcmp (name, "f")) 1474 else if (!strcmp (name, "f"))
1498 return S_F; 1475 return S_F;
1499 else if (*name == '\\') /* #\w (character) */ 1476 else if (*name == '\\') /* #\w (character) */
1500 { 1477 {
1501 int c; 1478 int c;
1502 1479
1480 // TODO: optimise
1503 if (stricmp (name + 1, "space") == 0) 1481 if (stricmp (name + 1, "space") == 0)
1504 c = ' '; 1482 c = ' ';
1505 else if (stricmp (name + 1, "newline") == 0) 1483 else if (stricmp (name + 1, "newline") == 0)
1506 c = '\n'; 1484 c = '\n';
1507 else if (stricmp (name + 1, "return") == 0) 1485 else if (stricmp (name + 1, "return") == 0)
1508 c = '\r'; 1486 c = '\r';
1509 else if (stricmp (name + 1, "tab") == 0) 1487 else if (stricmp (name + 1, "tab") == 0)
1510 c = '\t'; 1488 c = '\t';
1489 else if (stricmp (name + 1, "alarm") == 0)
1490 c = 0x07;
1491 else if (stricmp (name + 1, "backspace") == 0)
1492 c = 0x08;
1493 else if (stricmp (name + 1, "escape") == 0)
1494 c = 0x1b;
1495 else if (stricmp (name + 1, "delete") == 0)
1496 c = 0x7f;
1497 else if (stricmp (name + 1, "null") == 0)
1498 c = 0;
1511 else if (name[1] == 'x' && name[2] != 0) 1499 else if (name[1] == 'x' && name[2] != 0)
1512 { 1500 {
1513 long c1 = strtol (name + 2, 0, 16); 1501 long c1 = strtol (name + 2, 0, 16);
1514 1502
1515 if (0 <= c1 && c1 <= UCHAR_MAX) 1503 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1540 return NIL; 1528 return NIL;
1541 } 1529 }
1542} 1530}
1543 1531
1544/* ========== garbage collector ========== */ 1532/* ========== garbage collector ========== */
1533
1534static void
1535finalize_cell (SCHEME_P_ pointer a)
1536{
1537 /* TODO, fast bitmap check? */
1538 if (is_string (a) || is_symbol (a))
1539 free (strvalue (a));
1540 else if (is_vector (a))
1541 free (vecvalue (a));
1542#if USE_PORTS
1543 else if (is_port (a))
1544 {
1545 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1546 port_close (SCHEME_A_ a, port_input | port_output);
1547
1548 free (port (a));
1549 }
1550#endif
1551}
1545 1552
1546/*-- 1553/*--
1547 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1554 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1548 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1555 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1549 * for marking. 1556 * for marking.
1550 * 1557 *
1551 * The exception is vectors - vectors are currently marked recursively, 1558 * The exception is vectors - vectors are currently marked recursively,
1552 * which is inherited form tinyscheme and could be fixed by having another 1559 * which is inherited form tinyscheme and could be fixed by having another
1553 * word of context in the vector 1560 * word of context in the vector
1554 */ 1561 */
1555static void 1562ecb_hot static void
1556mark (pointer a) 1563mark (pointer a)
1557{ 1564{
1558 pointer t, q, p; 1565 pointer t, q, p;
1559 1566
1560 t = 0; 1567 t = 0;
… …
1617 p = q; 1624 p = q;
1618 goto E6; 1625 goto E6;
1619 } 1626 }
1620} 1627}
1621 1628
1629ecb_hot static void
1630gc_free (SCHEME_P)
1631{
1632 int i;
1633 uint32_t total = 0;
1634
1635 /* Here we scan the cells to build the free-list. */
1636 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1637 {
1638 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1639 struct cell *p;
1640 total += SCHEME_V->cell_segsize [i];
1641
1642 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1643 {
1644 pointer c = POINTER (p);
1645
1646 if (is_mark (c))
1647 clrmark (c);
1648 else
1649 {
1650 /* reclaim cell */
1651 if (typeflag (c) != T_PAIR)
1652 {
1653 finalize_cell (SCHEME_A_ c);
1654 set_typeflag (c, T_PAIR);
1655 set_car (c, NIL);
1656 }
1657
1658 ++SCHEME_V->fcells;
1659 set_cdr (c, SCHEME_V->free_cell);
1660 SCHEME_V->free_cell = c;
1661 }
1662 }
1663 }
1664
1665 if (SCHEME_V->gc_verbose)
1666 {
1667 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");
1668 }
1669}
1670
1622/* garbage collection. parameter a, b is marked. */ 1671/* garbage collection. parameter a, b is marked. */
1623static void 1672ecb_cold static void
1624gc (SCHEME_P_ pointer a, pointer b) 1673gc (SCHEME_P_ pointer a, pointer b)
1625{ 1674{
1626 pointer p;
1627 int i; 1675 int i;
1628 1676
1629 if (SCHEME_V->gc_verbose) 1677 if (SCHEME_V->gc_verbose)
1630 putstr (SCHEME_A_ "gc..."); 1678 putstr (SCHEME_A_ "gc...");
1631 1679
… …
1647 /* Mark recent objects the interpreter doesn't know about yet. */ 1695 /* Mark recent objects the interpreter doesn't know about yet. */
1648 mark (car (S_SINK)); 1696 mark (car (S_SINK));
1649 /* Mark any older stuff above nested C calls */ 1697 /* Mark any older stuff above nested C calls */
1650 mark (SCHEME_V->c_nest); 1698 mark (SCHEME_V->c_nest);
1651 1699
1700#if USE_INTCACHE
1701 /* mark intcache */
1702 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1703 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1704 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1705#endif
1706
1652 /* mark variables a, b */ 1707 /* mark variables a, b */
1653 mark (a); 1708 mark (a);
1654 mark (b); 1709 mark (b);
1655 1710
1656 /* garbage collect */ 1711 /* garbage collect */
1657 clrmark (NIL); 1712 clrmark (NIL);
1658 SCHEME_V->fcells = 0; 1713 SCHEME_V->fcells = 0;
1659 SCHEME_V->free_cell = NIL; 1714 SCHEME_V->free_cell = NIL;
1660 1715
1661 uint32_t total = 0;
1662
1663 /* Here we scan the cells to build the free-list. */
1664 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1665 {
1666 pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1667 total += SCHEME_V->cell_segsize [i];
1668
1669 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1670 {
1671 if (is_mark (p))
1672 clrmark (p);
1673 else
1674 {
1675 /* reclaim cell */
1676 if (typeflag (p) != T_PAIR)
1677 {
1678 finalize_cell (SCHEME_A_ p);
1679 set_typeflag (p, T_PAIR);
1680 set_car (p, NIL);
1681 }
1682
1683 ++SCHEME_V->fcells;
1684 set_cdr (p, SCHEME_V->free_cell);
1685 SCHEME_V->free_cell = p;
1686 }
1687 }
1688 }
1689
1690 if (SCHEME_V->gc_verbose) 1716 if (SCHEME_V->gc_verbose)
1691 { 1717 putstr (SCHEME_A_ "freeing...");
1692 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n");
1693 }
1694}
1695 1718
1696static void 1719 gc_free (SCHEME_A);
1697finalize_cell (SCHEME_P_ pointer a)
1698{
1699 /* TODO, fast bitmap check? */
1700 if (is_string (a) || is_symbol (a))
1701 free (strvalue (a));
1702 else if (is_vector (a))
1703 free (vecvalue (a));
1704#if USE_PORTS
1705 else if (is_port (a))
1706 {
1707 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit)
1708 port_close (SCHEME_A_ a, port_input | port_output);
1709
1710 free (a->object.port);
1711 }
1712#endif
1713} 1720}
1714 1721
1715/* ========== Routines for Reading ========== */ 1722/* ========== Routines for Reading ========== */
1716 1723
1717static int 1724ecb_cold static int
1718file_push (SCHEME_P_ const char *fname) 1725file_push (SCHEME_P_ const char *fname)
1719{ 1726{
1720#if USE_PORTS 1727#if USE_PORTS
1721 int fin; 1728 int fin;
1722 1729
… …
1731 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1738 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1732 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1739 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1733 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; 1740 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1734 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; 1741 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1735 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1742 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1736 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1743 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1737 1744
1738#if SHOW_ERROR_LINE 1745#if SHOW_ERROR_LINE
1739 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1746 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1740 1747
1741 if (fname) 1748 if (fname)
… …
1748#else 1755#else
1749 return 1; 1756 return 1;
1750#endif 1757#endif
1751} 1758}
1752 1759
1753static void 1760ecb_cold static void
1754file_pop (SCHEME_P) 1761file_pop (SCHEME_P)
1755{ 1762{
1756 if (SCHEME_V->file_i != 0) 1763 if (SCHEME_V->file_i != 0)
1757 { 1764 {
1758 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1765 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1759#if USE_PORTS 1766#if USE_PORTS
1760 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1767 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1761#endif 1768#endif
1762 SCHEME_V->file_i--; 1769 SCHEME_V->file_i--;
1763 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1770 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1764 } 1771 }
1765} 1772}
1766 1773
1767static int 1774ecb_cold static int
1768file_interactive (SCHEME_P) 1775file_interactive (SCHEME_P)
1769{ 1776{
1770#if USE_PORTS 1777#if USE_PORTS
1771 return SCHEME_V->file_i == 0 1778 return SCHEME_V->file_i == 0
1772 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1779 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1773 && (SCHEME_V->inport->object.port->kind & port_file); 1780 && (port (SCHEME_V->inport)->kind & port_file);
1774#else 1781#else
1775 return 0; 1782 return 0;
1776#endif 1783#endif
1777} 1784}
1778 1785
1779#if USE_PORTS 1786#if USE_PORTS
1780static port * 1787ecb_cold static port *
1781port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1788port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1782{ 1789{
1783 int fd; 1790 int fd;
1784 int flags; 1791 int flags;
1785 char *rw; 1792 char *rw;
… …
1808# endif 1815# endif
1809 1816
1810 return pt; 1817 return pt;
1811} 1818}
1812 1819
1813static pointer 1820ecb_cold static pointer
1814port_from_filename (SCHEME_P_ const char *fn, int prop) 1821port_from_filename (SCHEME_P_ const char *fn, int prop)
1815{ 1822{
1816 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1823 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1817 1824
1818 if (!pt && USE_ERROR_CHECKING) 1825 if (!pt && USE_ERROR_CHECKING)
1819 return NIL; 1826 return NIL;
1820 1827
1821 return mk_port (SCHEME_A_ pt); 1828 return mk_port (SCHEME_A_ pt);
1822} 1829}
1823 1830
1824static port * 1831ecb_cold static port *
1825port_rep_from_file (SCHEME_P_ int f, int prop) 1832port_rep_from_file (SCHEME_P_ int f, int prop)
1826{ 1833{
1827 port *pt = malloc (sizeof *pt); 1834 port *pt = malloc (sizeof *pt);
1828 1835
1829 if (!pt && USE_ERROR_CHECKING) 1836 if (!pt && USE_ERROR_CHECKING)
… …
1834 pt->rep.stdio.file = f; 1841 pt->rep.stdio.file = f;
1835 pt->rep.stdio.closeit = 0; 1842 pt->rep.stdio.closeit = 0;
1836 return pt; 1843 return pt;
1837} 1844}
1838 1845
1839static pointer 1846ecb_cold static pointer
1840port_from_file (SCHEME_P_ int f, int prop) 1847port_from_file (SCHEME_P_ int f, int prop)
1841{ 1848{
1842 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1849 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1843 1850
1844 if (!pt && USE_ERROR_CHECKING) 1851 if (!pt && USE_ERROR_CHECKING)
1845 return NIL; 1852 return NIL;
1846 1853
1847 return mk_port (SCHEME_A_ pt); 1854 return mk_port (SCHEME_A_ pt);
1848} 1855}
1849 1856
1850static port * 1857ecb_cold static port *
1851port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1858port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1852{ 1859{
1853 port *pt = malloc (sizeof (port)); 1860 port *pt = malloc (sizeof (port));
1854 1861
1855 if (!pt && USE_ERROR_CHECKING) 1862 if (!pt && USE_ERROR_CHECKING)
… …
1861 pt->rep.string.curr = start; 1868 pt->rep.string.curr = start;
1862 pt->rep.string.past_the_end = past_the_end; 1869 pt->rep.string.past_the_end = past_the_end;
1863 return pt; 1870 return pt;
1864} 1871}
1865 1872
1866static pointer 1873ecb_cold static pointer
1867port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1874port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1868{ 1875{
1869 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1876 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1870 1877
1871 if (!pt && USE_ERROR_CHECKING) 1878 if (!pt && USE_ERROR_CHECKING)
… …
1874 return mk_port (SCHEME_A_ pt); 1881 return mk_port (SCHEME_A_ pt);
1875} 1882}
1876 1883
1877# define BLOCK_SIZE 256 1884# define BLOCK_SIZE 256
1878 1885
1879static port * 1886ecb_cold static port *
1880port_rep_from_scratch (SCHEME_P) 1887port_rep_from_scratch (SCHEME_P)
1881{ 1888{
1882 char *start; 1889 char *start;
1883 port *pt = malloc (sizeof (port)); 1890 port *pt = malloc (sizeof (port));
1884 1891
… …
1898 pt->rep.string.curr = start; 1905 pt->rep.string.curr = start;
1899 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1906 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1900 return pt; 1907 return pt;
1901} 1908}
1902 1909
1903static pointer 1910ecb_cold static pointer
1904port_from_scratch (SCHEME_P) 1911port_from_scratch (SCHEME_P)
1905{ 1912{
1906 port *pt = port_rep_from_scratch (SCHEME_A); 1913 port *pt = port_rep_from_scratch (SCHEME_A);
1907 1914
1908 if (!pt && USE_ERROR_CHECKING) 1915 if (!pt && USE_ERROR_CHECKING)
1909 return NIL; 1916 return NIL;
1910 1917
1911 return mk_port (SCHEME_A_ pt); 1918 return mk_port (SCHEME_A_ pt);
1912} 1919}
1913 1920
1914static void 1921ecb_cold static void
1915port_close (SCHEME_P_ pointer p, int flag) 1922port_close (SCHEME_P_ pointer p, int flag)
1916{ 1923{
1917 port *pt = p->object.port; 1924 port *pt = port (p);
1918 1925
1919 pt->kind &= ~flag; 1926 pt->kind &= ~flag;
1920 1927
1921 if ((pt->kind & (port_input | port_output)) == 0) 1928 if ((pt->kind & (port_input | port_output)) == 0)
1922 { 1929 {
… …
1943/* get new character from input file */ 1950/* get new character from input file */
1944static int 1951static int
1945inchar (SCHEME_P) 1952inchar (SCHEME_P)
1946{ 1953{
1947 int c; 1954 int c;
1948 port *pt; 1955 port *pt = port (SCHEME_V->inport);
1949
1950 pt = SCHEME_V->inport->object.port;
1951 1956
1952 if (pt->kind & port_saw_EOF) 1957 if (pt->kind & port_saw_EOF)
1953 return EOF; 1958 return EOF;
1954 1959
1955 c = basic_inchar (pt); 1960 c = basic_inchar (pt);
… …
2022 port *pt; 2027 port *pt;
2023 2028
2024 if (c == EOF) 2029 if (c == EOF)
2025 return; 2030 return;
2026 2031
2027 pt = SCHEME_V->inport->object.port; 2032 pt = port (SCHEME_V->inport);
2028 pt->unget = c; 2033 pt->unget = c;
2029#else 2034#else
2030 if (c == EOF) 2035 if (c == EOF)
2031 return; 2036 return;
2032 2037
2033 ungot = c; 2038 ungot = c;
2034#endif 2039#endif
2035} 2040}
2036 2041
2037#if USE_PORTS 2042#if USE_PORTS
2038static int 2043ecb_cold static int
2039realloc_port_string (SCHEME_P_ port *p) 2044realloc_port_string (SCHEME_P_ port *p)
2040{ 2045{
2041 char *start = p->rep.string.start; 2046 char *start = p->rep.string.start;
2042 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2047 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2043 char *str = malloc (new_size); 2048 char *str = malloc (new_size);
… …
2056 else 2061 else
2057 return 0; 2062 return 0;
2058} 2063}
2059#endif 2064#endif
2060 2065
2061INTERFACE void 2066ecb_cold INTERFACE void
2062putstr (SCHEME_P_ const char *s) 2067putstr (SCHEME_P_ const char *s)
2063{ 2068{
2064#if USE_PORTS 2069#if USE_PORTS
2065 port *pt = SCHEME_V->outport->object.port; 2070 port *pt = port (SCHEME_V->outport);
2066 2071
2067 if (pt->kind & port_file) 2072 if (pt->kind & port_file)
2068 write (pt->rep.stdio.file, s, strlen (s)); 2073 write (pt->rep.stdio.file, s, strlen (s));
2069 else 2074 else
2070 for (; *s; s++) 2075 for (; *s; s++)
… …
2072 *pt->rep.string.curr++ = *s; 2077 *pt->rep.string.curr++ = *s;
2073 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) 2078 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2074 *pt->rep.string.curr++ = *s; 2079 *pt->rep.string.curr++ = *s;
2075 2080
2076#else 2081#else
2077 xwrstr (s); 2082 write (pt->rep.stdio.file, s, strlen (s));
2078#endif 2083#endif
2079} 2084}
2080 2085
2081static void 2086ecb_cold static void
2082putchars (SCHEME_P_ const char *s, int len) 2087putchars (SCHEME_P_ const char *s, int len)
2083{ 2088{
2084#if USE_PORTS 2089#if USE_PORTS
2085 port *pt = SCHEME_V->outport->object.port; 2090 port *pt = port (SCHEME_V->outport);
2086 2091
2087 if (pt->kind & port_file) 2092 if (pt->kind & port_file)
2088 write (pt->rep.stdio.file, s, len); 2093 write (pt->rep.stdio.file, s, len);
2089 else 2094 else
2090 { 2095 {
… …
2100#else 2105#else
2101 write (1, s, len); 2106 write (1, s, len);
2102#endif 2107#endif
2103} 2108}
2104 2109
2105INTERFACE void 2110ecb_cold INTERFACE void
2106putcharacter (SCHEME_P_ int c) 2111putcharacter (SCHEME_P_ int c)
2107{ 2112{
2108#if USE_PORTS 2113#if USE_PORTS
2109 port *pt = SCHEME_V->outport->object.port; 2114 port *pt = port (SCHEME_V->outport);
2110 2115
2111 if (pt->kind & port_file) 2116 if (pt->kind & port_file)
2112 { 2117 {
2113 char cc = c; 2118 char cc = c;
2114 write (pt->rep.stdio.file, &cc, 1); 2119 write (pt->rep.stdio.file, &cc, 1);
… …
2126 write (1, &c, 1); 2131 write (1, &c, 1);
2127#endif 2132#endif
2128} 2133}
2129 2134
2130/* read characters up to delimiter, but cater to character constants */ 2135/* read characters up to delimiter, but cater to character constants */
2131static char * 2136ecb_cold static char *
2132readstr_upto (SCHEME_P_ int skip, const char *delim) 2137readstr_upto (SCHEME_P_ int skip, const char *delim)
2133{ 2138{
2134 char *p = SCHEME_V->strbuff + skip; 2139 char *p = SCHEME_V->strbuff + skip;
2135 2140
2136 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2141 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
… …
2145 2150
2146 return SCHEME_V->strbuff; 2151 return SCHEME_V->strbuff;
2147} 2152}
2148 2153
2149/* read string expression "xxx...xxx" */ 2154/* read string expression "xxx...xxx" */
2150static pointer 2155ecb_cold static pointer
2151readstrexp (SCHEME_P_ char delim) 2156readstrexp (SCHEME_P_ char delim)
2152{ 2157{
2153 char *p = SCHEME_V->strbuff; 2158 char *p = SCHEME_V->strbuff;
2154 int c; 2159 int c;
2155 int c1 = 0; 2160 int c1 = 0;
… …
2188 case '7': 2193 case '7':
2189 state = st_oct1; 2194 state = st_oct1;
2190 c1 = c - '0'; 2195 c1 = c - '0';
2191 break; 2196 break;
2192 2197
2198 case 'a': *p++ = '\a'; state = st_ok; break;
2199 case 'n': *p++ = '\n'; state = st_ok; break;
2200 case 'r': *p++ = '\r'; state = st_ok; break;
2201 case 't': *p++ = '\t'; state = st_ok; break;
2202
2203 //TODO: \whitespace eol whitespace
2204
2205 //TODO: x should end in ;, not two-digit hex
2193 case 'x': 2206 case 'x':
2194 case 'X': 2207 case 'X':
2195 state = st_x1; 2208 state = st_x1;
2196 c1 = 0; 2209 c1 = 0;
2197 break;
2198
2199 case 'n':
2200 *p++ = '\n';
2201 state = st_ok;
2202 break;
2203
2204 case 't':
2205 *p++ = '\t';
2206 state = st_ok;
2207 break;
2208
2209 case 'r':
2210 *p++ = '\r';
2211 state = st_ok;
2212 break; 2210 break;
2213 2211
2214 default: 2212 default:
2215 *p++ = c; 2213 *p++ = c;
2216 state = st_ok; 2214 state = st_ok;
… …
2268 } 2266 }
2269 } 2267 }
2270} 2268}
2271 2269
2272/* check c is in chars */ 2270/* check c is in chars */
2273ecb_inline int 2271ecb_cold int
2274is_one_of (const char *s, int c) 2272is_one_of (const char *s, int c)
2275{ 2273{
2276 return c == EOF || !!strchr (s, c); 2274 return c == EOF || !!strchr (s, c);
2277} 2275}
2278 2276
2279/* skip white characters */ 2277/* skip white characters */
2280ecb_inline int 2278ecb_cold int
2281skipspace (SCHEME_P) 2279skipspace (SCHEME_P)
2282{ 2280{
2283 int c, curr_line = 0; 2281 int c, curr_line = 0;
2284 2282
2285 do 2283 do
… …
2305 backchar (SCHEME_A_ c); 2303 backchar (SCHEME_A_ c);
2306 return 1; 2304 return 1;
2307} 2305}
2308 2306
2309/* get token */ 2307/* get token */
2310static int 2308ecb_cold static int
2311token (SCHEME_P) 2309token (SCHEME_P)
2312{ 2310{
2313 int c = skipspace (SCHEME_A); 2311 int c = skipspace (SCHEME_A);
2314 2312
2315 if (c == EOF) 2313 if (c == EOF)
… …
2413} 2411}
2414 2412
2415/* ========== Routines for Printing ========== */ 2413/* ========== Routines for Printing ========== */
2416#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2414#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2417 2415
2418static void 2416ecb_cold static void
2419printslashstring (SCHEME_P_ char *p, int len) 2417printslashstring (SCHEME_P_ char *p, int len)
2420{ 2418{
2421 int i; 2419 int i;
2422 unsigned char *s = (unsigned char *) p; 2420 unsigned char *s = (unsigned char *) p;
2423 2421
… …
2479 2477
2480 putcharacter (SCHEME_A_ '"'); 2478 putcharacter (SCHEME_A_ '"');
2481} 2479}
2482 2480
2483/* print atoms */ 2481/* print atoms */
2484static void 2482ecb_cold static void
2485printatom (SCHEME_P_ pointer l, int f) 2483printatom (SCHEME_P_ pointer l, int f)
2486{ 2484{
2487 char *p; 2485 char *p;
2488 int len; 2486 int len;
2489 2487
2490 atom2str (SCHEME_A_ l, f, &p, &len); 2488 atom2str (SCHEME_A_ l, f, &p, &len);
2491 putchars (SCHEME_A_ p, len); 2489 putchars (SCHEME_A_ p, len);
2492} 2490}
2493 2491
2494/* Uses internal buffer unless string pointer is already available */ 2492/* Uses internal buffer unless string pointer is already available */
2495static void 2493ecb_cold static void
2496atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2494atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2497{ 2495{
2498 char *p; 2496 char *p;
2499 2497
2500 if (l == NIL) 2498 if (l == NIL)
… …
2707 return car (d); 2705 return car (d);
2708 2706
2709 p = cons (car (d), cdr (d)); 2707 p = cons (car (d), cdr (d));
2710 q = p; 2708 q = p;
2711 2709
2712 while (cdr (cdr (p)) != NIL) 2710 while (cddr (p) != NIL)
2713 { 2711 {
2714 d = cons (car (p), cdr (p)); 2712 d = cons (car (p), cdr (p));
2715 2713
2716 if (cdr (cdr (p)) != NIL) 2714 if (cddr (p) != NIL)
2717 p = cdr (d); 2715 p = cdr (d);
2718 } 2716 }
2719 2717
2720 set_cdr (p, car (cdr (p))); 2718 set_cdr (p, cadr (p));
2721 return q; 2719 return q;
2722} 2720}
2723 2721
2724/* reverse list -- produce new list */ 2722/* reverse list -- produce new list */
2725static pointer 2723ecb_hot static pointer
2726reverse (SCHEME_P_ pointer a) 2724reverse (SCHEME_P_ pointer a)
2727{ 2725{
2728 /* a must be checked by gc */ 2726 /* a must be checked by gc */
2729 pointer p = NIL; 2727 pointer p = NIL;
2730 2728
… …
2733 2731
2734 return p; 2732 return p;
2735} 2733}
2736 2734
2737/* reverse list --- in-place */ 2735/* reverse list --- in-place */
2738static pointer 2736ecb_hot static pointer
2739reverse_in_place (SCHEME_P_ pointer term, pointer list) 2737reverse_in_place (SCHEME_P_ pointer term, pointer list)
2740{ 2738{
2741 pointer result = term; 2739 pointer result = term;
2742 pointer p = list; 2740 pointer p = list;
2743 2741
… …
2751 2749
2752 return result; 2750 return result;
2753} 2751}
2754 2752
2755/* append list -- produce new list (in reverse order) */ 2753/* append list -- produce new list (in reverse order) */
2756static pointer 2754ecb_hot static pointer
2757revappend (SCHEME_P_ pointer a, pointer b) 2755revappend (SCHEME_P_ pointer a, pointer b)
2758{ 2756{
2759 pointer result = a; 2757 pointer result = a;
2760 pointer p = b; 2758 pointer p = b;
2761 2759
… …
2770 2768
2771 return S_F; /* signal an error */ 2769 return S_F; /* signal an error */
2772} 2770}
2773 2771
2774/* equivalence of atoms */ 2772/* equivalence of atoms */
2775int 2773ecb_hot int
2776eqv (pointer a, pointer b) 2774eqv (pointer a, pointer b)
2777{ 2775{
2778 if (is_string (a)) 2776 if (is_string (a))
2779 { 2777 {
2780 if (is_string (b)) 2778 if (is_string (b))
… …
2874 } 2872 }
2875 else 2873 else
2876 set_car (env, immutable_cons (slot, car (env))); 2874 set_car (env, immutable_cons (slot, car (env)));
2877} 2875}
2878 2876
2879static pointer 2877ecb_hot static pointer
2880find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2878find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2881{ 2879{
2882 pointer x, y; 2880 pointer x, y;
2883 2881
2884 for (x = env; x != NIL; x = cdr (x)) 2882 for (x = env; x != NIL; x = cdr (x))
… …
2905 return NIL; 2903 return NIL;
2906} 2904}
2907 2905
2908#else /* USE_ALIST_ENV */ 2906#else /* USE_ALIST_ENV */
2909 2907
2910ecb_inline void 2908static void
2911new_frame_in_env (SCHEME_P_ pointer old_env) 2909new_frame_in_env (SCHEME_P_ pointer old_env)
2912{ 2910{
2913 SCHEME_V->envir = immutable_cons (NIL, old_env); 2911 SCHEME_V->envir = immutable_cons (NIL, old_env);
2914 setenvironment (SCHEME_V->envir); 2912 setenvironment (SCHEME_V->envir);
2915} 2913}
2916 2914
2917ecb_inline void 2915static void
2918new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2916new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2919{ 2917{
2920 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2918 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2921} 2919}
2922 2920
2923static pointer 2921ecb_hot static pointer
2924find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2922find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2925{ 2923{
2926 pointer x, y; 2924 pointer x, y;
2927 2925
2928 for (x = env; x != NIL; x = cdr (x)) 2926 for (x = env; x != NIL; x = cdr (x))
… …
2942 return NIL; 2940 return NIL;
2943} 2941}
2944 2942
2945#endif /* USE_ALIST_ENV else */ 2943#endif /* USE_ALIST_ENV else */
2946 2944
2947ecb_inline void 2945static void
2948new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2946new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2949{ 2947{
2950 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 2948 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2951 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2949 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2952} 2950}
2953 2951
2954ecb_inline void 2952static void
2955set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2953set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2956{ 2954{
2957 set_cdr (slot, value); 2955 set_cdr (slot, value);
2958} 2956}
2959 2957
2960ecb_inline pointer 2958static pointer
2961slot_value_in_env (pointer slot) 2959slot_value_in_env (pointer slot)
2962{ 2960{
2963 return cdr (slot); 2961 return cdr (slot);
2964} 2962}
2965 2963
2966/* ========== Evaluation Cycle ========== */ 2964/* ========== Evaluation Cycle ========== */
2967 2965
2968static int 2966ecb_cold static int
2969xError_1 (SCHEME_P_ const char *s, pointer a) 2967xError_1 (SCHEME_P_ const char *s, pointer a)
2970{ 2968{
2971#if USE_ERROR_HOOK 2969#if USE_ERROR_HOOK
2972 pointer x; 2970 pointer x;
2973 pointer hdl = SCHEME_V->ERROR_HOOK; 2971 pointer hdl = SCHEME_V->ERROR_HOOK;
… …
3049 pointer code; 3047 pointer code;
3050}; 3048};
3051 3049
3052# define STACK_GROWTH 3 3050# define STACK_GROWTH 3
3053 3051
3054static void 3052ecb_hot static void
3055s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3053s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3056{ 3054{
3057 int nframes = (uintptr_t)SCHEME_V->dump; 3055 int nframes = (uintptr_t)SCHEME_V->dump;
3058 struct dump_stack_frame *next_frame; 3056 struct dump_stack_frame *next_frame;
3059 3057
3060 /* enough room for the next frame? */ 3058 /* enough room for the next frame? */
3061 if (nframes >= SCHEME_V->dump_size) 3059 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3062 { 3060 {
3063 SCHEME_V->dump_size += STACK_GROWTH; 3061 SCHEME_V->dump_size += STACK_GROWTH;
3064 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); 3062 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3065 } 3063 }
3066 3064
… …
3072 next_frame->code = code; 3070 next_frame->code = code;
3073 3071
3074 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3072 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3075} 3073}
3076 3074
3077static int 3075static ecb_hot int
3078xs_return (SCHEME_P_ pointer a) 3076xs_return (SCHEME_P_ pointer a)
3079{ 3077{
3080 int nframes = (uintptr_t)SCHEME_V->dump; 3078 int nframes = (uintptr_t)SCHEME_V->dump;
3081 struct dump_stack_frame *frame; 3079 struct dump_stack_frame *frame;
3082 3080
… …
3093 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3091 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3094 3092
3095 return 0; 3093 return 0;
3096} 3094}
3097 3095
3098ecb_inline void 3096ecb_cold void
3099dump_stack_reset (SCHEME_P) 3097dump_stack_reset (SCHEME_P)
3100{ 3098{
3101 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3099 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3102 SCHEME_V->dump = (pointer)+0; 3100 SCHEME_V->dump = (pointer)+0;
3103} 3101}
3104 3102
3105ecb_inline void 3103ecb_cold void
3106dump_stack_initialize (SCHEME_P) 3104dump_stack_initialize (SCHEME_P)
3107{ 3105{
3108 SCHEME_V->dump_size = 0; 3106 SCHEME_V->dump_size = 0;
3109 SCHEME_V->dump_base = 0; 3107 SCHEME_V->dump_base = 0;
3110 dump_stack_reset (SCHEME_A); 3108 dump_stack_reset (SCHEME_A);
3111} 3109}
3112 3110
3113static void 3111ecb_cold static void
3114dump_stack_free (SCHEME_P) 3112dump_stack_free (SCHEME_P)
3115{ 3113{
3116 free (SCHEME_V->dump_base); 3114 free (SCHEME_V->dump_base);
3117 SCHEME_V->dump_base = 0; 3115 SCHEME_V->dump_base = 0;
3118 SCHEME_V->dump = (pointer)0; 3116 SCHEME_V->dump = (pointer)0;
3119 SCHEME_V->dump_size = 0; 3117 SCHEME_V->dump_size = 0;
3120} 3118}
3121 3119
3122static void 3120ecb_cold static void
3123dump_stack_mark (SCHEME_P) 3121dump_stack_mark (SCHEME_P)
3124{ 3122{
3125 int nframes = (uintptr_t)SCHEME_V->dump; 3123 int nframes = (uintptr_t)SCHEME_V->dump;
3126 int i; 3124 int i;
3127 3125
… …
3133 mark (frame->envir); 3131 mark (frame->envir);
3134 mark (frame->code); 3132 mark (frame->code);
3135 } 3133 }
3136} 3134}
3137 3135
3138static pointer 3136ecb_cold static pointer
3139ss_get_cont (SCHEME_P) 3137ss_get_cont (SCHEME_P)
3140{ 3138{
3141 int nframes = (uintptr_t)SCHEME_V->dump; 3139 int nframes = (uintptr_t)SCHEME_V->dump;
3142 int i; 3140 int i;
3143 3141
… …
3155 } 3153 }
3156 3154
3157 return cont; 3155 return cont;
3158} 3156}
3159 3157
3160static void 3158ecb_cold static void
3161ss_set_cont (SCHEME_P_ pointer cont) 3159ss_set_cont (SCHEME_P_ pointer cont)
3162{ 3160{
3163 int i = 0; 3161 int i = 0;
3164 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3162 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3165 3163
… …
3177 SCHEME_V->dump = (pointer)(uintptr_t)i; 3175 SCHEME_V->dump = (pointer)(uintptr_t)i;
3178} 3176}
3179 3177
3180#else 3178#else
3181 3179
3182ecb_inline void 3180ecb_cold void
3183dump_stack_reset (SCHEME_P) 3181dump_stack_reset (SCHEME_P)
3184{ 3182{
3185 SCHEME_V->dump = NIL; 3183 SCHEME_V->dump = NIL;
3186} 3184}
3187 3185
3188ecb_inline void 3186ecb_cold void
3189dump_stack_initialize (SCHEME_P) 3187dump_stack_initialize (SCHEME_P)
3190{ 3188{
3191 dump_stack_reset (SCHEME_A); 3189 dump_stack_reset (SCHEME_A);
3192} 3190}
3193 3191
3194static void 3192ecb_cold static void
3195dump_stack_free (SCHEME_P) 3193dump_stack_free (SCHEME_P)
3196{ 3194{
3197 SCHEME_V->dump = NIL; 3195 SCHEME_V->dump = NIL;
3198} 3196}
3199 3197
3200static int 3198ecb_hot static int
3201xs_return (SCHEME_P_ pointer a) 3199xs_return (SCHEME_P_ pointer a)
3202{ 3200{
3203 pointer dump = SCHEME_V->dump; 3201 pointer dump = SCHEME_V->dump;
3204 3202
3205 SCHEME_V->value = a; 3203 SCHEME_V->value = a;
… …
3215 SCHEME_V->dump = dump; 3213 SCHEME_V->dump = dump;
3216 3214
3217 return 0; 3215 return 0;
3218} 3216}
3219 3217
3220static void 3218ecb_hot static void
3221s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3219s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3222{ 3220{
3223 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3221 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3224 cons (args, 3222 cons (args,
3225 cons (SCHEME_V->envir, 3223 cons (SCHEME_V->envir,
3226 cons (code, 3224 cons (code,
3227 SCHEME_V->dump)))); 3225 SCHEME_V->dump))));
3228} 3226}
3229 3227
3230static void 3228ecb_cold static void
3231dump_stack_mark (SCHEME_P) 3229dump_stack_mark (SCHEME_P)
3232{ 3230{
3233 mark (SCHEME_V->dump); 3231 mark (SCHEME_V->dump);
3234} 3232}
3235 3233
3236static pointer 3234ecb_cold static pointer
3237ss_get_cont (SCHEME_P) 3235ss_get_cont (SCHEME_P)
3238{ 3236{
3239 return SCHEME_V->dump; 3237 return SCHEME_V->dump;
3240} 3238}
3241 3239
3242static void 3240ecb_cold static void
3243ss_set_cont (SCHEME_P_ pointer cont) 3241ss_set_cont (SCHEME_P_ pointer cont)
3244{ 3242{
3245 SCHEME_V->dump = cont; 3243 SCHEME_V->dump = cont;
3246} 3244}
3247 3245
… …
3305 break; 3303 break;
3306 } 3304 }
3307} 3305}
3308#endif 3306#endif
3309 3307
3310static int 3308/* syntax, eval, core, ... */
3309ecb_hot static int
3311opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3310opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3312{ 3311{
3313 pointer args = SCHEME_V->args; 3312 pointer args = SCHEME_V->args;
3314 pointer x, y; 3313 pointer x, y;
3315 3314
… …
3322 s_return (S_T); 3321 s_return (S_T);
3323#endif 3322#endif
3324 case OP_LOAD: /* load */ 3323 case OP_LOAD: /* load */
3325 if (file_interactive (SCHEME_A)) 3324 if (file_interactive (SCHEME_A))
3326 { 3325 {
3327 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3326 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
3328 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3327 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3329 } 3328 }
3330 3329
3331 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3330 if (!file_push (SCHEME_A_ strvalue (car (args))))
3332 Error_1 ("unable to open", car (args)); 3331 Error_1 ("unable to open", car (args));
3333 else 3332 else
… …
3337 } 3336 }
3338 3337
3339 case OP_T0LVL: /* top level */ 3338 case OP_T0LVL: /* top level */
3340 3339
3341 /* If we reached the end of file, this loop is done. */ 3340 /* If we reached the end of file, this loop is done. */
3342 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3341 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3343 { 3342 {
3344 if (SCHEME_V->file_i == 0) 3343 if (SCHEME_V->file_i == 0)
3345 { 3344 {
3346 SCHEME_V->args = NIL; 3345 SCHEME_V->args = NIL;
3347 s_goto (OP_QUIT); 3346 s_goto (OP_QUIT);
… …
3425#endif 3424#endif
3426 if (is_symbol (SCHEME_V->code)) /* symbol */ 3425 if (is_symbol (SCHEME_V->code)) /* symbol */
3427 { 3426 {
3428 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3427 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3429 3428
3430 if (x != NIL) 3429 if (x == NIL)
3431 s_return (slot_value_in_env (x));
3432 else
3433 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3430 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3431
3432 s_return (slot_value_in_env (x));
3434 } 3433 }
3435 else if (is_pair (SCHEME_V->code)) 3434 else if (is_pair (SCHEME_V->code))
3436 { 3435 {
3437 x = car (SCHEME_V->code); 3436 x = car (SCHEME_V->code);
3438 3437
… …
3515 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3514 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3516 else if (is_foreign (SCHEME_V->code)) 3515 else if (is_foreign (SCHEME_V->code))
3517 { 3516 {
3518 /* Keep nested calls from GC'ing the arglist */ 3517 /* Keep nested calls from GC'ing the arglist */
3519 push_recent_alloc (SCHEME_A_ args, NIL); 3518 push_recent_alloc (SCHEME_A_ args, NIL);
3520 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3519 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3521 3520
3522 s_return (x); 3521 s_return (x);
3523 } 3522 }
3524 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3523 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3525 { 3524 {
… …
3562 3561
3563 case OP_DOMACRO: /* do macro */ 3562 case OP_DOMACRO: /* do macro */
3564 SCHEME_V->code = SCHEME_V->value; 3563 SCHEME_V->code = SCHEME_V->value;
3565 s_goto (OP_EVAL); 3564 s_goto (OP_EVAL);
3566 3565
3567#if 1
3568
3569 case OP_LAMBDA: /* lambda */ 3566 case OP_LAMBDA: /* lambda */
3570 /* If the hook is defined, apply it to SCHEME_V->code, otherwise 3567 /* If the hook is defined, apply it to SCHEME_V->code, otherwise
3571 set SCHEME_V->value fall thru */ 3568 set SCHEME_V->value fall thru */
3572 { 3569 {
3573 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1); 3570 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->COMPILE_HOOK, 1);
… …
3579 SCHEME_V->code = slot_value_in_env (f); 3576 SCHEME_V->code = slot_value_in_env (f);
3580 s_goto (OP_APPLY); 3577 s_goto (OP_APPLY);
3581 } 3578 }
3582 3579
3583 SCHEME_V->value = SCHEME_V->code; 3580 SCHEME_V->value = SCHEME_V->code;
3584 /* Fallthru */
3585 } 3581 }
3582 /* Fallthru */
3586 3583
3587 case OP_LAMBDA1: 3584 case OP_LAMBDA1:
3588 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir)); 3585 s_return (mk_closure (SCHEME_A_ SCHEME_V->value, SCHEME_V->envir));
3589
3590#else
3591
3592 case OP_LAMBDA: /* lambda */
3593 s_return (mk_closure (SCHEME_A_ SCHEME_V->code, SCHEME_V->envir));
3594
3595#endif
3596 3586
3597 case OP_MKCLOSURE: /* make-closure */ 3587 case OP_MKCLOSURE: /* make-closure */
3598 x = car (args); 3588 x = car (args);
3599 3589
3600 if (car (x) == SCHEME_V->LAMBDA) 3590 if (car (x) == SCHEME_V->LAMBDA)
… …
4010 } 4000 }
4011 4001
4012 if (USE_ERROR_CHECKING) abort (); 4002 if (USE_ERROR_CHECKING) abort ();
4013} 4003}
4014 4004
4015static int 4005/* math, cxr */
4006ecb_hot static int
4016opexe_1 (SCHEME_P_ enum scheme_opcodes op) 4007opexe_1 (SCHEME_P_ enum scheme_opcodes op)
4017{ 4008{
4018 pointer args = SCHEME_V->args; 4009 pointer args = SCHEME_V->args;
4019 pointer x = car (args); 4010 pointer x = car (args);
4020 num v; 4011 num v;
4021 4012
4022 switch (op) 4013 switch (op)
4023 { 4014 {
4024#if USE_MATH 4015#if USE_MATH
4025 case OP_INEX2EX: /* inexact->exact */ 4016 case OP_INEX2EX: /* inexact->exact */
4026 {
4027 if (is_integer (x)) 4017 if (!is_integer (x))
4028 s_return (x); 4018 {
4029
4030 RVALUE r = rvalue_unchecked (x); 4019 RVALUE r = rvalue_unchecked (x);
4031 4020
4032 if (r == (RVALUE)(IVALUE)r) 4021 if (r == (RVALUE)(IVALUE)r)
4033 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4022 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4034 else 4023 else
4035 Error_1 ("inexact->exact: not integral:", x); 4024 Error_1 ("inexact->exact: not integral:", x);
4036 } 4025 }
4037 4026
4027 s_return (x);
4028
4029 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4030 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4031 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4032 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4033
4034 case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4038 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4035 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4039 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4036 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4037 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4040 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4038 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4041 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4039 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4042 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4040 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4043 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4041 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4044 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4042 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4045 4043
4046 case OP_ATAN: 4044 case OP_ATAN:
4045 s_return (mk_real (SCHEME_A_
4047 if (cdr (args) == NIL) 4046 cdr (args) == NIL
4048 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4047 ? atan (rvalue (x))
4049 else 4048 : atan2 (rvalue (x), rvalue (cadr (args)))));
4050 {
4051 pointer y = cadr (args);
4052 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4053 }
4054
4055 case OP_SQRT:
4056 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4057 4049
4058 case OP_EXPT: 4050 case OP_EXPT:
4059 { 4051 {
4060 RVALUE result; 4052 RVALUE result;
4061 int real_result = 1; 4053 int real_result = 1;
… …
4084 if (real_result) 4076 if (real_result)
4085 s_return (mk_real (SCHEME_A_ result)); 4077 s_return (mk_real (SCHEME_A_ result));
4086 else 4078 else
4087 s_return (mk_integer (SCHEME_A_ result)); 4079 s_return (mk_integer (SCHEME_A_ result));
4088 } 4080 }
4089
4090 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4091 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4092
4093 case OP_TRUNCATE:
4094 {
4095 RVALUE n = rvalue (x);
4096 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4097 }
4098
4099 case OP_ROUND:
4100 if (is_integer (x))
4101 s_return (x);
4102
4103 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4104#endif 4081#endif
4105 4082
4106 case OP_ADD: /* + */ 4083 case OP_ADD: /* + */
4107 v = num_zero; 4084 v = num_zero;
4108 4085
… …
4196 else 4173 else
4197 Error_0 ("modulo: division by zero"); 4174 Error_0 ("modulo: division by zero");
4198 4175
4199 s_return (mk_number (SCHEME_A_ v)); 4176 s_return (mk_number (SCHEME_A_ v));
4200 4177
4201 case OP_CAR: /* car */ 4178 /* the compiler will optimize this mess... */
4202 s_return (caar (args)); 4179 case OP_CAR: op_car: s_return (car (x));
4203 4180 case OP_CDR: op_cdr: s_return (cdr (x));
4204 case OP_CDR: /* cdr */ 4181 case OP_CAAR: op_caar: x = car (x); goto op_car;
4205 s_return (cdar (args)); 4182 case OP_CADR: op_cadr: x = cdr (x); goto op_car;
4183 case OP_CDAR: op_cdar: x = car (x); goto op_cdr;
4184 case OP_CDDR: op_cddr: x = cdr (x); goto op_cdr;
4185 case OP_CAAAR: op_caaar: x = car (x); goto op_caar;
4186 case OP_CAADR: op_caadr: x = cdr (x); goto op_caar;
4187 case OP_CADAR: op_cadar: x = car (x); goto op_cadr;
4188 case OP_CADDR: op_caddr: x = cdr (x); goto op_cadr;
4189 case OP_CDAAR: op_cdaar: x = car (x); goto op_cdar;
4190 case OP_CDADR: op_cdadr: x = cdr (x); goto op_cdar;
4191 case OP_CDDAR: op_cddar: x = car (x); goto op_cddr;
4192 case OP_CDDDR: op_cdddr: x = cdr (x); goto op_cddr;
4193 case OP_CAAAAR: x = car (x); goto op_caaar;
4194 case OP_CAAADR: x = cdr (x); goto op_caaar;
4195 case OP_CAADAR: x = car (x); goto op_caadr;
4196 case OP_CAADDR: x = cdr (x); goto op_caadr;
4197 case OP_CADAAR: x = car (x); goto op_cadar;
4198 case OP_CADADR: x = cdr (x); goto op_cadar;
4199 case OP_CADDAR: x = car (x); goto op_caddr;
4200 case OP_CADDDR: x = cdr (x); goto op_caddr;
4201 case OP_CDAAAR: x = car (x); goto op_cdaar;
4202 case OP_CDAADR: x = cdr (x); goto op_cdaar;
4203 case OP_CDADAR: x = car (x); goto op_cdadr;
4204 case OP_CDADDR: x = cdr (x); goto op_cdadr;
4205 case OP_CDDAAR: x = car (x); goto op_cddar;
4206 case OP_CDDADR: x = cdr (x); goto op_cddar;
4207 case OP_CDDDAR: x = car (x); goto op_cdddr;
4208 case OP_CDDDDR: x = cdr (x); goto op_cdddr;
4206 4209
4207 case OP_CONS: /* cons */ 4210 case OP_CONS: /* cons */
4208 set_cdr (args, cadr (args)); 4211 set_cdr (args, cadr (args));
4209 s_return (args); 4212 s_return (args);
4210 4213
… …
4384 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4387 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4385 4388
4386 s_return (newstr); 4389 s_return (newstr);
4387 } 4390 }
4388 4391
4389 case OP_SUBSTR: /* substring */ 4392 case OP_STRING_COPY: /* substring/string-copy */
4390 { 4393 {
4391 char *str = strvalue (x); 4394 char *str = strvalue (x);
4392 int index0 = ivalue_unchecked (cadr (args)); 4395 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4393 int index1; 4396 int index1;
4394 int len; 4397 int len;
4395 4398
4396 if (index0 > strlength (x)) 4399 if (index0 > strlength (x))
4397 Error_1 ("substring: start out of bounds:", cadr (args)); 4400 Error_1 ("string->copy: start out of bounds:", cadr (args));
4398 4401
4399 if (cddr (args) != NIL) 4402 if (cddr (args) != NIL)
4400 { 4403 {
4401 index1 = ivalue_unchecked (caddr (args)); 4404 index1 = ivalue_unchecked (caddr (args));
4402 4405
4403 if (index1 > strlength (x) || index1 < index0) 4406 if (index1 > strlength (x) || index1 < index0)
4404 Error_1 ("substring: end out of bounds:", caddr (args)); 4407 Error_1 ("string->copy: end out of bounds:", caddr (args));
4405 } 4408 }
4406 else 4409 else
4407 index1 = strlength (x); 4410 index1 = strlength (x);
4408 4411
4409 len = index1 - index0; 4412 len = index1 - index0;
4410 x = mk_empty_string (SCHEME_A_ len, ' '); 4413 x = mk_counted_string (SCHEME_A_ str + index0, len);
4411 memcpy (strvalue (x), str + index0, len);
4412 strvalue (x)[len] = 0;
4413 4414
4414 s_return (x); 4415 s_return (x);
4415 } 4416 }
4416 4417
4417 case OP_VECTOR: /* vector */ 4418 case OP_VECTOR: /* vector */
… …
4491 } 4492 }
4492 4493
4493 if (USE_ERROR_CHECKING) abort (); 4494 if (USE_ERROR_CHECKING) abort ();
4494} 4495}
4495 4496
4496static int 4497/* relational ops */
4498ecb_hot static int
4497opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4499opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4498{ 4500{
4499 pointer x = SCHEME_V->args; 4501 pointer x = SCHEME_V->args;
4500 4502
4501 for (;;) 4503 for (;;)
… …
4522 } 4524 }
4523 4525
4524 s_return (S_T); 4526 s_return (S_T);
4525} 4527}
4526 4528
4527static int 4529/* predicates */
4530ecb_hot static int
4528opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4531opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4529{ 4532{
4530 pointer args = SCHEME_V->args; 4533 pointer args = SCHEME_V->args;
4531 pointer a = car (args); 4534 pointer a = car (args);
4532 pointer d = cdr (args); 4535 pointer d = cdr (args);
… …
4579 } 4582 }
4580 4583
4581 s_retbool (r); 4584 s_retbool (r);
4582} 4585}
4583 4586
4584static int 4587/* promises, list ops, ports */
4588ecb_hot static int
4585opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4589opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4586{ 4590{
4587 pointer args = SCHEME_V->args; 4591 pointer args = SCHEME_V->args;
4588 pointer a = car (args); 4592 pointer a = car (args);
4589 pointer x, y; 4593 pointer x, y;
… …
4602 } 4606 }
4603 else 4607 else
4604 s_return (SCHEME_V->code); 4608 s_return (SCHEME_V->code);
4605 4609
4606 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4610 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4607 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4611 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4608 s_return (SCHEME_V->value); 4612 s_return (SCHEME_V->value);
4609 4613
4610#if USE_PORTS 4614#if USE_PORTS
4615
4616 case OP_EOF_OBJECT: /* eof-object */
4617 s_return (S_EOF);
4611 4618
4612 case OP_WRITE: /* write */ 4619 case OP_WRITE: /* write */
4613 case OP_DISPLAY: /* display */ 4620 case OP_DISPLAY: /* display */
4614 case OP_WRITE_CHAR: /* write-char */ 4621 case OP_WRITE_CHAR: /* write-char */
4615 if (is_pair (cdr (SCHEME_V->args))) 4622 if (is_pair (cdr (SCHEME_V->args)))
… …
4757 SCHEME_V->gc_verbose = (a != S_F); 4764 SCHEME_V->gc_verbose = (a != S_F);
4758 s_retbool (was); 4765 s_retbool (was);
4759 } 4766 }
4760 4767
4761 case OP_NEWSEGMENT: /* new-segment */ 4768 case OP_NEWSEGMENT: /* new-segment */
4769#if 0
4762 if (!is_pair (args) || !is_number (a)) 4770 if (!is_pair (args) || !is_number (a))
4763 Error_0 ("new-segment: argument must be a number"); 4771 Error_0 ("new-segment: argument must be a number");
4764 4772#endif
4765 alloc_cellseg (SCHEME_A_ ivalue (a)); 4773 s_retbool (alloc_cellseg (SCHEME_A));
4766
4767 s_return (S_T);
4768 4774
4769 case OP_OBLIST: /* oblist */ 4775 case OP_OBLIST: /* oblist */
4770 s_return (oblist_all_symbols (SCHEME_A)); 4776 s_return (oblist_all_symbols (SCHEME_A));
4771 4777
4772#if USE_PORTS 4778#if USE_PORTS
… …
4842 s_return (p == NIL ? S_F : p); 4848 s_return (p == NIL ? S_F : p);
4843 } 4849 }
4844 4850
4845 case OP_GET_OUTSTRING: /* get-output-string */ 4851 case OP_GET_OUTSTRING: /* get-output-string */
4846 { 4852 {
4847 port *p; 4853 port *p = port (a);
4848 4854
4849 if ((p = a->object.port)->kind & port_string) 4855 if (p->kind & port_string)
4850 { 4856 {
4851 off_t size; 4857 off_t size;
4852 char *str; 4858 char *str;
4853 4859
4854 size = p->rep.string.curr - p->rep.string.start + 1; 4860 size = p->rep.string.curr - p->rep.string.start + 1;
… …
4889 } 4895 }
4890 4896
4891 if (USE_ERROR_CHECKING) abort (); 4897 if (USE_ERROR_CHECKING) abort ();
4892} 4898}
4893 4899
4894static int 4900/* reading */
4901ecb_cold static int
4895opexe_5 (SCHEME_P_ enum scheme_opcodes op) 4902opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4896{ 4903{
4897 pointer args = SCHEME_V->args; 4904 pointer args = SCHEME_V->args;
4898 pointer x; 4905 pointer x;
4899 4906
… …
4959 int res; 4966 int res;
4960 4967
4961 if (is_pair (args)) 4968 if (is_pair (args))
4962 p = car (args); 4969 p = car (args);
4963 4970
4964 res = p->object.port->kind & port_string; 4971 res = port (p)->kind & port_string;
4965 4972
4966 s_retbool (res); 4973 s_retbool (res);
4967 } 4974 }
4968 4975
4969 case OP_SET_INPORT: /* set-input-port */ 4976 case OP_SET_INPORT: /* set-input-port */
… …
5241 } 5248 }
5242 5249
5243 if (USE_ERROR_CHECKING) abort (); 5250 if (USE_ERROR_CHECKING) abort ();
5244} 5251}
5245 5252
5246static int 5253/* list ops */
5254ecb_hot static int
5247opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5255opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5248{ 5256{
5249 pointer args = SCHEME_V->args; 5257 pointer args = SCHEME_V->args;
5250 pointer a = car (args); 5258 pointer a = car (args);
5251 pointer x, y; 5259 pointer x, y;
… …
5309 5317
5310/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5318/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5311typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); 5319typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5312 5320
5313typedef int (*test_predicate)(pointer); 5321typedef int (*test_predicate)(pointer);
5314static int 5322
5323ecb_hot static int
5315tst_any (pointer p) 5324tst_any (pointer p)
5316{ 5325{
5317 return 1; 5326 return 1;
5318} 5327}
5319 5328
5320static int 5329ecb_hot static int
5321tst_inonneg (pointer p) 5330tst_inonneg (pointer p)
5322{ 5331{
5323 return is_integer (p) && ivalue_unchecked (p) >= 0; 5332 return is_integer (p) && ivalue_unchecked (p) >= 0;
5324} 5333}
5325 5334
5326static int 5335ecb_hot static int
5327tst_is_list (SCHEME_P_ pointer p) 5336tst_is_list (SCHEME_P_ pointer p)
5328{ 5337{
5329 return p == NIL || is_pair (p); 5338 return p == NIL || is_pair (p);
5330} 5339}
5331 5340
… …
5374#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" 5383#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5375#include "opdefines.h" 5384#include "opdefines.h"
5376#undef OP_DEF 5385#undef OP_DEF
5377; 5386;
5378 5387
5379static const char * 5388ecb_cold static const char *
5380opname (int idx) 5389opname (int idx)
5381{ 5390{
5382 const char *name = opnames; 5391 const char *name = opnames;
5383 5392
5384 /* should do this at compile time, but would require external program, right? */ 5393 /* should do this at compile time, but would require external program, right? */
… …
5386 name += strlen (name) + 1; 5395 name += strlen (name) + 1;
5387 5396
5388 return *name ? name : "ILLEGAL"; 5397 return *name ? name : "ILLEGAL";
5389} 5398}
5390 5399
5391static const char * 5400ecb_cold static const char *
5392procname (pointer x) 5401procname (pointer x)
5393{ 5402{
5394 return opname (procnum (x)); 5403 return opname (procnum (x));
5395} 5404}
5396 5405
… …
5416#undef OP_DEF 5425#undef OP_DEF
5417 {0} 5426 {0}
5418}; 5427};
5419 5428
5420/* kernel of this interpreter */ 5429/* kernel of this interpreter */
5421static void ecb_hot 5430ecb_hot static void
5422Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5431Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5423{ 5432{
5424 SCHEME_V->op = op; 5433 SCHEME_V->op = op;
5425 5434
5426 for (;;) 5435 for (;;)
… …
5509 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) 5518 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5510 return; 5519 return;
5511 5520
5512 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5521 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5513 { 5522 {
5514 xwrstr ("No memory!\n"); 5523 putstr (SCHEME_A_ "No memory!\n");
5515 return; 5524 return;
5516 } 5525 }
5517 } 5526 }
5518} 5527}
5519 5528
5520/* ========== Initialization of internal keywords ========== */ 5529/* ========== Initialization of internal keywords ========== */
5521 5530
5522static void 5531ecb_cold static void
5523assign_syntax (SCHEME_P_ const char *name) 5532assign_syntax (SCHEME_P_ const char *name)
5524{ 5533{
5525 pointer x = oblist_add_by_name (SCHEME_A_ name); 5534 pointer x = oblist_add_by_name (SCHEME_A_ name);
5526 set_typeflag (x, typeflag (x) | T_SYNTAX); 5535 set_typeflag (x, typeflag (x) | T_SYNTAX);
5527} 5536}
5528 5537
5529static void 5538ecb_cold static void
5530assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5539assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5531{ 5540{
5532 pointer x = mk_symbol (SCHEME_A_ name); 5541 pointer x = mk_symbol (SCHEME_A_ name);
5533 pointer y = mk_proc (SCHEME_A_ op); 5542 pointer y = mk_proc (SCHEME_A_ op);
5534 new_slot_in_env (SCHEME_A_ x, y); 5543 new_slot_in_env (SCHEME_A_ x, y);
… …
5542 ivalue_unchecked (y) = op; 5551 ivalue_unchecked (y) = op;
5543 return y; 5552 return y;
5544} 5553}
5545 5554
5546/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5555/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5547static int 5556ecb_hot static int
5548syntaxnum (pointer p) 5557syntaxnum (pointer p)
5549{ 5558{
5550 const char *s = strvalue (p); 5559 const char *s = strvalue (p);
5551 5560
5552 switch (strlength (p)) 5561 switch (strlength (p))
… …
5632ecb_cold int 5641ecb_cold int
5633scheme_init (SCHEME_P) 5642scheme_init (SCHEME_P)
5634{ 5643{
5635 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5644 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5636 pointer x; 5645 pointer x;
5646
5647 /* this memset is not strictly correct, as we assume (intcache)
5648 * that memset 0 will also set pointers to 0, but memset does
5649 * of course not guarantee that. screw such systems.
5650 */
5651 memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5637 5652
5638 num_set_fixnum (num_zero, 1); 5653 num_set_fixnum (num_zero, 1);
5639 num_set_ivalue (num_zero, 0); 5654 num_set_ivalue (num_zero, 0);
5640 num_set_fixnum (num_one, 1); 5655 num_set_fixnum (num_one, 1);
5641 num_set_ivalue (num_one, 1); 5656 num_set_ivalue (num_one, 1);
… …
5653 SCHEME_V->save_inport = NIL; 5668 SCHEME_V->save_inport = NIL;
5654 SCHEME_V->loadport = NIL; 5669 SCHEME_V->loadport = NIL;
5655 SCHEME_V->nesting = 0; 5670 SCHEME_V->nesting = 0;
5656 SCHEME_V->interactive_repl = 0; 5671 SCHEME_V->interactive_repl = 0;
5657 5672
5658 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 5673 if (!alloc_cellseg (SCHEME_A))
5659 { 5674 {
5660#if USE_ERROR_CHECKING 5675#if USE_ERROR_CHECKING
5661 SCHEME_V->no_memory = 1; 5676 SCHEME_V->no_memory = 1;
5662 return 0; 5677 return 0;
5663#endif 5678#endif
… …
5731 5746
5732 return !SCHEME_V->no_memory; 5747 return !SCHEME_V->no_memory;
5733} 5748}
5734 5749
5735#if USE_PORTS 5750#if USE_PORTS
5736void 5751ecb_cold void
5737scheme_set_input_port_file (SCHEME_P_ int fin) 5752scheme_set_input_port_file (SCHEME_P_ int fin)
5738{ 5753{
5739 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 5754 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5740} 5755}
5741 5756
5742void 5757ecb_cold void
5743scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 5758scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5744{ 5759{
5745 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 5760 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5746} 5761}
5747 5762
5748void 5763ecb_cold void
5749scheme_set_output_port_file (SCHEME_P_ int fout) 5764scheme_set_output_port_file (SCHEME_P_ int fout)
5750{ 5765{
5751 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 5766 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5752} 5767}
5753 5768
5754void 5769ecb_cold void
5755scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 5770scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5756{ 5771{
5757 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 5772 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5758} 5773}
5759#endif 5774#endif
5760 5775
5761void 5776ecb_cold void
5762scheme_set_external_data (SCHEME_P_ void *p) 5777scheme_set_external_data (SCHEME_P_ void *p)
5763{ 5778{
5764 SCHEME_V->ext_data = p; 5779 SCHEME_V->ext_data = p;
5765} 5780}
5766 5781
… …
5814 } 5829 }
5815 } 5830 }
5816#endif 5831#endif
5817} 5832}
5818 5833
5819void 5834ecb_cold void
5820scheme_load_file (SCHEME_P_ int fin) 5835scheme_load_file (SCHEME_P_ int fin)
5821{ 5836{
5822 scheme_load_named_file (SCHEME_A_ fin, 0); 5837 scheme_load_named_file (SCHEME_A_ fin, 0);
5823} 5838}
5824 5839
5825void 5840ecb_cold void
5826scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 5841scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5827{ 5842{
5828 dump_stack_reset (SCHEME_A); 5843 dump_stack_reset (SCHEME_A);
5829 SCHEME_V->envir = SCHEME_V->global_env; 5844 SCHEME_V->envir = SCHEME_V->global_env;
5830 SCHEME_V->file_i = 0; 5845 SCHEME_V->file_i = 0;
… …
5857 5872
5858 if (SCHEME_V->retcode == 0) 5873 if (SCHEME_V->retcode == 0)
5859 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5874 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5860} 5875}
5861 5876
5862void 5877ecb_cold void
5863scheme_load_string (SCHEME_P_ const char *cmd) 5878scheme_load_string (SCHEME_P_ const char *cmd)
5864{ 5879{
5865 dump_stack_reset (SCHEME_A); 5880 dump_stack_reset (SCHEME_A);
5866 SCHEME_V->envir = SCHEME_V->global_env; 5881 SCHEME_V->envir = SCHEME_V->global_env;
5867 SCHEME_V->file_i = 0; 5882 SCHEME_V->file_i = 0;
… …
5881 5896
5882 if (SCHEME_V->retcode == 0) 5897 if (SCHEME_V->retcode == 0)
5883 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5898 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5884} 5899}
5885 5900
5886void 5901ecb_cold void
5887scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 5902scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5888{ 5903{
5889 pointer x; 5904 pointer x;
5890 5905
5891 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 5906 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5896 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 5911 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5897} 5912}
5898 5913
5899#if !STANDALONE 5914#if !STANDALONE
5900 5915
5901void 5916ecb_cold void
5902scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 5917scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5903{ 5918{
5904 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 5919 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5905} 5920}
5906 5921
5907void 5922ecb_cold void
5908scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 5923scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5909{ 5924{
5910 int i; 5925 int i;
5911 5926
5912 for (i = 0; i < count; i++) 5927 for (i = 0; i < count; i++)
5913 scheme_register_foreign_func (SCHEME_A_ list + i); 5928 scheme_register_foreign_func (SCHEME_A_ list + i);
5914} 5929}
5915 5930
5916pointer 5931ecb_cold pointer
5917scheme_apply0 (SCHEME_P_ const char *procname) 5932scheme_apply0 (SCHEME_P_ const char *procname)
5918{ 5933{
5919 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 5934 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5920} 5935}
5921 5936
5922void 5937ecb_cold void
5923save_from_C_call (SCHEME_P) 5938save_from_C_call (SCHEME_P)
5924{ 5939{
5925 pointer saved_data = cons (car (S_SINK), 5940 pointer saved_data = cons (car (S_SINK),
5926 cons (SCHEME_V->envir, 5941 cons (SCHEME_V->envir,
5927 SCHEME_V->dump)); 5942 SCHEME_V->dump));
… …
5931 /* Truncate the dump stack so TS will return here when done, not 5946 /* Truncate the dump stack so TS will return here when done, not
5932 directly resume pre-C-call operations. */ 5947 directly resume pre-C-call operations. */
5933 dump_stack_reset (SCHEME_A); 5948 dump_stack_reset (SCHEME_A);
5934} 5949}
5935 5950
5936void 5951ecb_cold void
5937restore_from_C_call (SCHEME_P) 5952restore_from_C_call (SCHEME_P)
5938{ 5953{
5939 set_car (S_SINK, caar (SCHEME_V->c_nest)); 5954 set_car (S_SINK, caar (SCHEME_V->c_nest));
5940 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 5955 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5941 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 5956 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5942 /* Pop */ 5957 /* Pop */
5943 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 5958 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5944} 5959}
5945 5960
5946/* "func" and "args" are assumed to be already eval'ed. */ 5961/* "func" and "args" are assumed to be already eval'ed. */
5947pointer 5962ecb_cold pointer
5948scheme_call (SCHEME_P_ pointer func, pointer args) 5963scheme_call (SCHEME_P_ pointer func, pointer args)
5949{ 5964{
5950 int old_repl = SCHEME_V->interactive_repl; 5965 int old_repl = SCHEME_V->interactive_repl;
5951 5966
5952 SCHEME_V->interactive_repl = 0; 5967 SCHEME_V->interactive_repl = 0;
… …
5959 SCHEME_V->interactive_repl = old_repl; 5974 SCHEME_V->interactive_repl = old_repl;
5960 restore_from_C_call (SCHEME_A); 5975 restore_from_C_call (SCHEME_A);
5961 return SCHEME_V->value; 5976 return SCHEME_V->value;
5962} 5977}
5963 5978
5964pointer 5979ecb_cold pointer
5965scheme_eval (SCHEME_P_ pointer obj) 5980scheme_eval (SCHEME_P_ pointer obj)
5966{ 5981{
5967 int old_repl = SCHEME_V->interactive_repl; 5982 int old_repl = SCHEME_V->interactive_repl;
5968 5983
5969 SCHEME_V->interactive_repl = 0; 5984 SCHEME_V->interactive_repl = 0;
… …
5981 5996
5982/* ========== Main ========== */ 5997/* ========== Main ========== */
5983 5998
5984#if STANDALONE 5999#if STANDALONE
5985 6000
5986int 6001ecb_cold int
5987main (int argc, char **argv) 6002main (int argc, char **argv)
5988{ 6003{
5989# if USE_MULTIPLICITY 6004# if USE_MULTIPLICITY
5990 scheme ssc; 6005 scheme ssc;
5991 scheme *const SCHEME_V = &ssc; 6006 scheme *const SCHEME_V = &ssc;
… …
5997 int isfile = 1; 6012 int isfile = 1;
5998 system ("ps v $PPID");//D 6013 system ("ps v $PPID");//D
5999 6014
6000 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6015 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6001 { 6016 {
6002 xwrstr ("Usage: tinyscheme -?\n"); 6017 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6003 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6018 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6004 xwrstr ("followed by\n"); 6019 putstr (SCHEME_A_ "followed by\n");
6005 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6020 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6006 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6021 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6007 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6022 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6008 xwrstr ("Use - as filename for stdin.\n"); 6023 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6009 return 1; 6024 return 1;
6010 } 6025 }
6011 6026
6012 if (!scheme_init (SCHEME_A)) 6027 if (!scheme_init (SCHEME_A))
6013 { 6028 {
6014 xwrstr ("Could not initialize!\n"); 6029 putstr (SCHEME_A_ "Could not initialize!\n");
6015 return 2; 6030 return 2;
6016 } 6031 }
6017 6032
6018# if USE_PORTS 6033# if USE_PORTS
6019 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6034 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6064 fin = open (file_name, O_RDONLY); 6079 fin = open (file_name, O_RDONLY);
6065#endif 6080#endif
6066 6081
6067 if (isfile && fin < 0) 6082 if (isfile && fin < 0)
6068 { 6083 {
6069 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6084 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6070 } 6085 }
6071 else 6086 else
6072 { 6087 {
6073 if (isfile) 6088 if (isfile)
6074 scheme_load_named_file (SCHEME_A_ fin, file_name); 6089 scheme_load_named_file (SCHEME_A_ fin, file_name);
… …
6078#if USE_PORTS 6093#if USE_PORTS
6079 if (!isfile || fin != STDIN_FILENO) 6094 if (!isfile || fin != STDIN_FILENO)
6080 { 6095 {
6081 if (SCHEME_V->retcode != 0) 6096 if (SCHEME_V->retcode != 0)
6082 { 6097 {
6083 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6098 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6084 } 6099 }
6085 6100
6086 if (isfile) 6101 if (isfile)
6087 close (fin); 6102 close (fin);
6088 } 6103 }

Diff Legend

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