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.54 by root, Tue Dec 1 02:42:35 2015 UTC vs.
Revision 1.61 by root, Wed Dec 2 07:43:46 2015 UTC

… …
16 * (MINISCM) This is a revised and modified version by Akira KIDA. 16 * (MINISCM) This is a revised and modified version by Akira KIDA.
17 * (MINISCM) current version is 0.85k4 (15 May 1994) 17 * (MINISCM) current version is 0.85k4 (15 May 1994)
18 * 18 *
19 */ 19 */
20 20
21#define EXPERIMENT 1 21#define _GNU_SOURCE 1
22#define _POSIX_C_SOURCE 200201
23#define _XOPEN_SOURCE 600
22 24
23#if 1
24#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
25#include "malloc.c"
26#endif
27 25
28#define SCHEME_SOURCE 26#define SCHEME_SOURCE
29#include "scheme-private.h" 27#include "scheme-private.h"
30#ifndef WIN32 28#ifndef WIN32
31# include <unistd.h> 29# include <unistd.h>
… …
49#include <string.h> 47#include <string.h>
50 48
51#include <limits.h> 49#include <limits.h>
52#include <inttypes.h> 50#include <inttypes.h>
53#include <float.h> 51#include <float.h>
54//#include <ctype.h> 52
53#if !USE_SYSTEM_MALLOC
54# define PAGE_SIZE 4096 /* does not work on sparc/alpha */
55# include "malloc.c"
56# define malloc(n) tiny_malloc (n)
57# define realloc(p,n) tiny_realloc (p, n)
58# define free(p) tiny_free (p)
59#endif
55 60
56#if '1' != '0' + 1 \ 61#if '1' != '0' + 1 \
57 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \ 62 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
58 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \ 63 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
59 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \ 64 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
… …
91 96
92#if !USE_MULTIPLICITY 97#if !USE_MULTIPLICITY
93static scheme sc; 98static scheme sc;
94#endif 99#endif
95 100
96static void 101ecb_cold static void
97xbase (char *s, long n, int base) 102xbase (char *s, long n, int base)
98{ 103{
99 if (n < 0) 104 if (n < 0)
100 { 105 {
101 *s++ = '-'; 106 *s++ = '-';
… …
116 char x = *s; *s = *p; *p = x; 121 char x = *s; *s = *p; *p = x;
117 --p; ++s; 122 --p; ++s;
118 } 123 }
119} 124}
120 125
121static void 126ecb_cold static void
122xnum (char *s, long n) 127xnum (char *s, long n)
123{ 128{
124 xbase (s, n, 10); 129 xbase (s, n, 10);
125} 130}
126 131
127static void 132ecb_cold static void
128putnum (SCHEME_P_ long n) 133putnum (SCHEME_P_ long n)
129{ 134{
130 char buf[64]; 135 char buf[64];
131 136
132 xnum (buf, n); 137 xnum (buf, n);
133 putstr (SCHEME_A_ buf); 138 putstr (SCHEME_A_ buf);
134} 139}
140
141#if USE_CHAR_CLASSIFIERS
142#include <ctype.h>
143#else
135 144
136static char 145static char
137xtoupper (char c) 146xtoupper (char c)
138{ 147{
139 if (c >= 'a' && c <= 'z') 148 if (c >= 'a' && c <= 'z')
… …
159 168
160#define toupper(c) xtoupper (c) 169#define toupper(c) xtoupper (c)
161#define tolower(c) xtolower (c) 170#define tolower(c) xtolower (c)
162#define isdigit(c) xisdigit (c) 171#define isdigit(c) xisdigit (c)
163 172
173#endif
174
164#if USE_IGNORECASE 175#if USE_IGNORECASE
165static const char * 176ecb_cold static const char *
166xstrlwr (char *s) 177xstrlwr (char *s)
167{ 178{
168 const char *p = s; 179 const char *p = s;
169 180
170 while (*s) 181 while (*s)
… …
193#endif 204#endif
194 205
195enum scheme_types 206enum scheme_types
196{ 207{
197 T_INTEGER, 208 T_INTEGER,
209 T_CHARACTER,
198 T_REAL, 210 T_REAL,
199 T_STRING, 211 T_STRING,
200 T_SYMBOL, 212 T_SYMBOL,
201 T_PROC, 213 T_PROC,
202 T_PAIR, /* also used for free cells */ 214 T_PAIR, /* also used for free cells */
203 T_CLOSURE, 215 T_CLOSURE,
216 T_BYTECODE, // temp
217 T_MACRO,
204 T_CONTINUATION, 218 T_CONTINUATION,
205 T_FOREIGN, 219 T_FOREIGN,
206 T_CHARACTER,
207 T_PORT, 220 T_PORT,
208 T_VECTOR, 221 T_VECTOR,
209 T_MACRO,
210 T_PROMISE, 222 T_PROMISE,
211 T_ENVIRONMENT, 223 T_ENVIRONMENT,
212 /* one more... */ 224
213 T_NUM_SYSTEM_TYPES 225 T_NUM_SYSTEM_TYPES
214}; 226};
215 227
216#define T_MASKTYPE 0x000f 228#define T_MASKTYPE 0x000f
217#define T_SYNTAX 0x0010 229#define T_SYNTAX 0x0010
… …
520 proper list: length 532 proper list: length
521 circular list: -1 533 circular list: -1
522 not even a pair: -2 534 not even a pair: -2
523 dotted list: -2 minus length before dot 535 dotted list: -2 minus length before dot
524*/ 536*/
525INTERFACE int 537ecb_hot INTERFACE int
526list_length (SCHEME_P_ pointer a) 538list_length (SCHEME_P_ pointer a)
527{ 539{
528 int i = 0; 540 int i = 0;
529 pointer slow, fast; 541 pointer slow, fast;
530 542
… …
569{ 581{
570 return list_length (SCHEME_A_ a) >= 0; 582 return list_length (SCHEME_A_ a) >= 0;
571} 583}
572 584
573#if USE_CHAR_CLASSIFIERS 585#if USE_CHAR_CLASSIFIERS
586
574ecb_inline int 587ecb_inline int
575Cisalpha (int c) 588Cisalpha (int c)
576{ 589{
577 return isascii (c) && isalpha (c); 590 return isascii (c) && isalpha (c);
578} 591}
… …
636 "gs", 649 "gs",
637 "rs", 650 "rs",
638 "us" 651 "us"
639}; 652};
640 653
641static int 654ecb_cold static int
642is_ascii_name (const char *name, int *pc) 655is_ascii_name (const char *name, int *pc)
643{ 656{
644 int i; 657 int i;
645 658
646 for (i = 0; i < 32; i++) 659 for (i = 0; i < 32; i++)
… …
668static int file_interactive (SCHEME_P); 681static int file_interactive (SCHEME_P);
669ecb_inline int is_one_of (const char *s, int c); 682ecb_inline int is_one_of (const char *s, int c);
670static int alloc_cellseg (SCHEME_P); 683static int alloc_cellseg (SCHEME_P);
671ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 684ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
672static void finalize_cell (SCHEME_P_ pointer a); 685static void finalize_cell (SCHEME_P_ pointer a);
673static int count_consecutive_cells (pointer x, int needed);
674static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 686static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
675static pointer mk_number (SCHEME_P_ const num n); 687static pointer mk_number (SCHEME_P_ const num n);
676static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 688static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
677static pointer mk_vector (SCHEME_P_ uint32_t len); 689static pointer mk_vector (SCHEME_P_ uint32_t len);
678static pointer mk_atom (SCHEME_P_ char *q); 690static pointer mk_atom (SCHEME_P_ char *q);
679static pointer mk_sharp_const (SCHEME_P_ char *name); 691static pointer mk_sharp_const (SCHEME_P_ char *name);
680 692
693static pointer mk_port (SCHEME_P_ port *p);
694
681#if USE_PORTS 695#if USE_PORTS
682static pointer mk_port (SCHEME_P_ port *p);
683static pointer port_from_filename (SCHEME_P_ const char *fn, int prop); 696static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
684static pointer port_from_file (SCHEME_P_ int, int prop); 697static pointer port_from_file (SCHEME_P_ int, int prop);
685static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 698static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
686static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop); 699static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop);
687static port *port_rep_from_file (SCHEME_P_ int, int prop); 700static port *port_rep_from_file (SCHEME_P_ int, int prop);
688static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 701static port *port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop);
689static void port_close (SCHEME_P_ pointer p, int flag); 702static void port_close (SCHEME_P_ pointer p, int flag);
690#endif 703#endif
704
691static void mark (pointer a); 705static void mark (pointer a);
692static void gc (SCHEME_P_ pointer a, pointer b); 706static void gc (SCHEME_P_ pointer a, pointer b);
693static int basic_inchar (port *pt); 707static int basic_inchar (port *pt);
694static int inchar (SCHEME_P); 708static int inchar (SCHEME_P);
695static void backchar (SCHEME_P_ int c); 709static void backchar (SCHEME_P_ int c);
… …
883#endif 897#endif
884#endif 898#endif
885} 899}
886 900
887/* allocate new cell segment */ 901/* allocate new cell segment */
888static int 902ecb_cold static int
889alloc_cellseg (SCHEME_P) 903alloc_cellseg (SCHEME_P)
890{ 904{
891 struct cell *newp; 905 struct cell *newp;
892 struct cell *last; 906 struct cell *last;
893 struct cell *p; 907 struct cell *p;
… …
935 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 949 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
936 return S_SINK; 950 return S_SINK;
937 951
938 if (SCHEME_V->free_cell == NIL) 952 if (SCHEME_V->free_cell == NIL)
939 { 953 {
940 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1; 954 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
941 955
942 gc (SCHEME_A_ a, b); 956 gc (SCHEME_A_ a, b);
943 957
944 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 958 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
945 { 959 {
… …
964 } 978 }
965} 979}
966 980
967/* To retain recent allocs before interpreter knows about them - 981/* To retain recent allocs before interpreter knows about them -
968 Tehom */ 982 Tehom */
969static void 983ecb_hot static void
970push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 984push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
971{ 985{
972 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 986 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
973 987
974 set_typeflag (holder, T_PAIR); 988 set_typeflag (holder, T_PAIR);
… …
976 set_car (holder, recent); 990 set_car (holder, recent);
977 set_cdr (holder, car (S_SINK)); 991 set_cdr (holder, car (S_SINK));
978 set_car (S_SINK, holder); 992 set_car (S_SINK, holder);
979} 993}
980 994
981static pointer 995ecb_hot static pointer
982get_cell (SCHEME_P_ pointer a, pointer b) 996get_cell (SCHEME_P_ pointer a, pointer b)
983{ 997{
984 pointer cell = get_cell_x (SCHEME_A_ a, b); 998 pointer cell = get_cell_x (SCHEME_A_ a, b);
985 999
986 /* For right now, include "a" and "b" in "cell" so that gc doesn't 1000 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1043#endif 1057#endif
1044 1058
1045/* Medium level cell allocation */ 1059/* Medium level cell allocation */
1046 1060
1047/* get new cons cell */ 1061/* get new cons cell */
1048pointer 1062ecb_hot static pointer
1049xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1063xcons (SCHEME_P_ pointer a, pointer b)
1050{ 1064{
1051 pointer x = get_cell (SCHEME_A_ a, b); 1065 pointer x = get_cell (SCHEME_A_ a, b);
1052 1066
1053 set_typeflag (x, T_PAIR); 1067 set_typeflag (x, T_PAIR);
1054
1055 if (immutable)
1056 setimmutable (x);
1057 1068
1058 set_car (x, a); 1069 set_car (x, a);
1059 set_cdr (x, b); 1070 set_cdr (x, b);
1060 1071
1061 return x; 1072 return x;
1062} 1073}
1063 1074
1064static pointer 1075ecb_hot static pointer
1076ximmutable_cons (SCHEME_P_ pointer a, pointer b)
1077{
1078 pointer x = xcons (SCHEME_A_ a, b);
1079 setimmutable (x);
1080 return x;
1081}
1082
1083#define cons(a,b) xcons (SCHEME_A_ a, b)
1084#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1085
1086ecb_cold static pointer
1065generate_symbol (SCHEME_P_ const char *name) 1087generate_symbol (SCHEME_P_ const char *name)
1066{ 1088{
1067 pointer x = mk_string (SCHEME_A_ name); 1089 pointer x = mk_string (SCHEME_A_ name);
1068 setimmutable (x); 1090 setimmutable (x);
1069 set_typeflag (x, T_SYMBOL | T_ATOM); 1091 set_typeflag (x, T_SYMBOL | T_ATOM);
… …
1075#ifndef USE_OBJECT_LIST 1097#ifndef USE_OBJECT_LIST
1076 1098
1077static int 1099static int
1078hash_fn (const char *key, int table_size) 1100hash_fn (const char *key, int table_size)
1079{ 1101{
1080 const unsigned char *p = key; 1102 const unsigned char *p = (unsigned char *)key;
1081 uint32_t hash = 2166136261; 1103 uint32_t hash = 2166136261;
1082 1104
1083 while (*p) 1105 while (*p)
1084 hash = (hash ^ *p++) * 16777619; 1106 hash = (hash ^ *p++) * 16777619;
1085 1107
1086 return hash % table_size; 1108 return hash % table_size;
1087} 1109}
1088 1110
1089static pointer 1111ecb_cold static pointer
1090oblist_initial_value (SCHEME_P) 1112oblist_initial_value (SCHEME_P)
1091{ 1113{
1092 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1114 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1093} 1115}
1094 1116
1095/* returns the new symbol */ 1117/* returns the new symbol */
1096static pointer 1118ecb_cold static pointer
1097oblist_add_by_name (SCHEME_P_ const char *name) 1119oblist_add_by_name (SCHEME_P_ const char *name)
1098{ 1120{
1099 pointer x = generate_symbol (SCHEME_A_ name); 1121 pointer x = generate_symbol (SCHEME_A_ name);
1100 int location = hash_fn (name, veclength (SCHEME_V->oblist)); 1122 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1101 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location))); 1123 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1102 return x; 1124 return x;
1103} 1125}
1104 1126
1105ecb_inline pointer 1127ecb_cold static pointer
1106oblist_find_by_name (SCHEME_P_ const char *name) 1128oblist_find_by_name (SCHEME_P_ const char *name)
1107{ 1129{
1108 int location; 1130 int location;
1109 pointer x; 1131 pointer x;
1110 char *s; 1132 char *s;
… …
1121 } 1143 }
1122 1144
1123 return NIL; 1145 return NIL;
1124} 1146}
1125 1147
1126static pointer 1148ecb_cold static pointer
1127oblist_all_symbols (SCHEME_P) 1149oblist_all_symbols (SCHEME_P)
1128{ 1150{
1129 int i; 1151 int i;
1130 pointer x; 1152 pointer x;
1131 pointer ob_list = NIL; 1153 pointer ob_list = NIL;
… …
1137 return ob_list; 1159 return ob_list;
1138} 1160}
1139 1161
1140#else 1162#else
1141 1163
1142static pointer 1164ecb_cold static pointer
1143oblist_initial_value (SCHEME_P) 1165oblist_initial_value (SCHEME_P)
1144{ 1166{
1145 return NIL; 1167 return NIL;
1146} 1168}
1147 1169
1148ecb_inline pointer 1170ecb_cold static pointer
1149oblist_find_by_name (SCHEME_P_ const char *name) 1171oblist_find_by_name (SCHEME_P_ const char *name)
1150{ 1172{
1151 pointer x; 1173 pointer x;
1152 char *s; 1174 char *s;
1153 1175
… …
1162 1184
1163 return NIL; 1185 return NIL;
1164} 1186}
1165 1187
1166/* returns the new symbol */ 1188/* returns the new symbol */
1167static pointer 1189ecb_cold static pointer
1168oblist_add_by_name (SCHEME_P_ const char *name) 1190oblist_add_by_name (SCHEME_P_ const char *name)
1169{ 1191{
1170 pointer x = generate_symbol (SCHEME_A_ name); 1192 pointer x = generate_symbol (SCHEME_A_ name);
1171 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1193 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1172 return x; 1194 return x;
1173} 1195}
1174 1196
1175static pointer 1197ecb_cold static pointer
1176oblist_all_symbols (SCHEME_P) 1198oblist_all_symbols (SCHEME_P)
1177{ 1199{
1178 return SCHEME_V->oblist; 1200 return SCHEME_V->oblist;
1179} 1201}
1180 1202
1181#endif 1203#endif
1182 1204
1183#if USE_PORTS
1184static pointer 1205ecb_cold static pointer
1185mk_port (SCHEME_P_ port *p) 1206mk_port (SCHEME_P_ port *p)
1186{ 1207{
1187 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1208 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1188 1209
1189 set_typeflag (x, T_PORT | T_ATOM); 1210 set_typeflag (x, T_PORT | T_ATOM);
1190 set_port (x, p); 1211 set_port (x, p);
1191 1212
1192 return x; 1213 return x;
1193} 1214}
1194#endif
1195 1215
1196pointer 1216ecb_cold pointer
1197mk_foreign_func (SCHEME_P_ foreign_func f) 1217mk_foreign_func (SCHEME_P_ foreign_func f)
1198{ 1218{
1199 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1219 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1200 1220
1201 set_typeflag (x, T_FOREIGN | T_ATOM); 1221 set_typeflag (x, T_FOREIGN | T_ATOM);
… …
1366 x = oblist_add_by_name (SCHEME_A_ name); 1386 x = oblist_add_by_name (SCHEME_A_ name);
1367 1387
1368 return x; 1388 return x;
1369} 1389}
1370 1390
1371INTERFACE pointer 1391ecb_cold INTERFACE pointer
1372gensym (SCHEME_P) 1392gensym (SCHEME_P)
1373{ 1393{
1374 pointer x; 1394 pointer x;
1375 char name[40] = "gensym-"; 1395 char name[40] = "gensym-";
1376 xnum (name + 7, ++SCHEME_V->gensym_cnt); 1396 xnum (name + 7, ++SCHEME_V->gensym_cnt);
… …
1383{ 1403{
1384 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; 1404 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1385} 1405}
1386 1406
1387/* make symbol or number atom from string */ 1407/* make symbol or number atom from string */
1388static pointer 1408ecb_cold static pointer
1389mk_atom (SCHEME_P_ char *q) 1409mk_atom (SCHEME_P_ char *q)
1390{ 1410{
1391 char c, *p; 1411 char c, *p;
1392 int has_dec_point = 0; 1412 int has_dec_point = 0;
1393 int has_fp_exp = 0; 1413 int has_fp_exp = 0;
… …
1464 1484
1465 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1485 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1466} 1486}
1467 1487
1468/* make constant */ 1488/* make constant */
1469static pointer 1489ecb_cold static pointer
1470mk_sharp_const (SCHEME_P_ char *name) 1490mk_sharp_const (SCHEME_P_ char *name)
1471{ 1491{
1472 if (!strcmp (name, "t")) 1492 if (!strcmp (name, "t"))
1473 return S_T; 1493 return S_T;
1474 else if (!strcmp (name, "f")) 1494 else if (!strcmp (name, "f"))
1475 return S_F; 1495 return S_F;
1476 else if (*name == '\\') /* #\w (character) */ 1496 else if (*name == '\\') /* #\w (character) */
1477 { 1497 {
1478 int c; 1498 int c;
1479 1499
1500 // TODO: optimise
1480 if (stricmp (name + 1, "space") == 0) 1501 if (stricmp (name + 1, "space") == 0)
1481 c = ' '; 1502 c = ' ';
1482 else if (stricmp (name + 1, "newline") == 0) 1503 else if (stricmp (name + 1, "newline") == 0)
1483 c = '\n'; 1504 c = '\n';
1484 else if (stricmp (name + 1, "return") == 0) 1505 else if (stricmp (name + 1, "return") == 0)
1485 c = '\r'; 1506 c = '\r';
1486 else if (stricmp (name + 1, "tab") == 0) 1507 else if (stricmp (name + 1, "tab") == 0)
1487 c = '\t'; 1508 c = '\t';
1509 else if (stricmp (name + 1, "alarm") == 0)
1510 c = 0x07;
1511 else if (stricmp (name + 1, "backspace") == 0)
1512 c = 0x08;
1513 else if (stricmp (name + 1, "escape") == 0)
1514 c = 0x1b;
1515 else if (stricmp (name + 1, "delete") == 0)
1516 c = 0x7f;
1517 else if (stricmp (name + 1, "null") == 0)
1518 c = 0;
1488 else if (name[1] == 'x' && name[2] != 0) 1519 else if (name[1] == 'x' && name[2] != 0)
1489 { 1520 {
1490 long c1 = strtol (name + 2, 0, 16); 1521 long c1 = strtol (name + 2, 0, 16);
1491 1522
1492 if (0 <= c1 && c1 <= UCHAR_MAX) 1523 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1517 return NIL; 1548 return NIL;
1518 } 1549 }
1519} 1550}
1520 1551
1521/* ========== garbage collector ========== */ 1552/* ========== garbage collector ========== */
1553
1554static void
1555finalize_cell (SCHEME_P_ pointer a)
1556{
1557 /* TODO, fast bitmap check? */
1558 if (is_string (a) || is_symbol (a))
1559 free (strvalue (a));
1560 else if (is_vector (a))
1561 free (vecvalue (a));
1562#if USE_PORTS
1563 else if (is_port (a))
1564 {
1565 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1566 port_close (SCHEME_A_ a, port_input | port_output);
1567
1568 free (port (a));
1569 }
1570#endif
1571}
1522 1572
1523/*-- 1573/*--
1524 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1574 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1525 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1575 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1526 * for marking. 1576 * for marking.
1527 * 1577 *
1528 * The exception is vectors - vectors are currently marked recursively, 1578 * The exception is vectors - vectors are currently marked recursively,
1529 * which is inherited form tinyscheme and could be fixed by having another 1579 * which is inherited form tinyscheme and could be fixed by having another
1530 * word of context in the vector 1580 * word of context in the vector
1531 */ 1581 */
1532static void 1582ecb_hot static void
1533mark (pointer a) 1583mark (pointer a)
1534{ 1584{
1535 pointer t, q, p; 1585 pointer t, q, p;
1536 1586
1537 t = 0; 1587 t = 0;
… …
1594 p = q; 1644 p = q;
1595 goto E6; 1645 goto E6;
1596 } 1646 }
1597} 1647}
1598 1648
1599/* garbage collection. parameter a, b is marked. */ 1649ecb_hot static void
1600static void 1650gc_free (SCHEME_P)
1601gc (SCHEME_P_ pointer a, pointer b)
1602{ 1651{
1603 int i; 1652 int i;
1604
1605 if (SCHEME_V->gc_verbose)
1606 putstr (SCHEME_A_ "gc...");
1607
1608 /* mark system globals */
1609 mark (SCHEME_V->oblist);
1610 mark (SCHEME_V->global_env);
1611
1612 /* mark current registers */
1613 mark (SCHEME_V->args);
1614 mark (SCHEME_V->envir);
1615 mark (SCHEME_V->code);
1616 dump_stack_mark (SCHEME_A);
1617 mark (SCHEME_V->value);
1618 mark (SCHEME_V->inport);
1619 mark (SCHEME_V->save_inport);
1620 mark (SCHEME_V->outport);
1621 mark (SCHEME_V->loadport);
1622
1623 /* Mark recent objects the interpreter doesn't know about yet. */
1624 mark (car (S_SINK));
1625 /* Mark any older stuff above nested C calls */
1626 mark (SCHEME_V->c_nest);
1627
1628#if USE_INTCACHE
1629 /* mark intcache */
1630 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1631 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1632 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1633#endif
1634
1635 /* mark variables a, b */
1636 mark (a);
1637 mark (b);
1638
1639 /* garbage collect */
1640 clrmark (NIL);
1641 SCHEME_V->fcells = 0;
1642 SCHEME_V->free_cell = NIL;
1643
1644 if (SCHEME_V->gc_verbose)
1645 putstr (SCHEME_A_ "freeing...");
1646
1647 uint32_t total = 0; 1653 uint32_t total = 0;
1648 1654
1649 /* Here we scan the cells to build the free-list. */ 1655 /* Here we scan the cells to build the free-list. */
1650 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1656 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1651 { 1657 {
… …
1680 { 1686 {
1681 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"); 1687 putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n");
1682 } 1688 }
1683} 1689}
1684 1690
1685static void 1691/* garbage collection. parameter a, b is marked. */
1686finalize_cell (SCHEME_P_ pointer a) 1692ecb_cold static void
1693gc (SCHEME_P_ pointer a, pointer b)
1687{ 1694{
1688 /* TODO, fast bitmap check? */ 1695 int i;
1689 if (is_string (a) || is_symbol (a))
1690 free (strvalue (a));
1691 else if (is_vector (a))
1692 free (vecvalue (a));
1693#if USE_PORTS
1694 else if (is_port (a))
1695 {
1696 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1697 port_close (SCHEME_A_ a, port_input | port_output);
1698 1696
1699 free (port (a)); 1697 if (SCHEME_V->gc_verbose)
1700 } 1698 putstr (SCHEME_A_ "gc...");
1699
1700 /* mark system globals */
1701 mark (SCHEME_V->oblist);
1702 mark (SCHEME_V->global_env);
1703
1704 /* mark current registers */
1705 mark (SCHEME_V->args);
1706 mark (SCHEME_V->envir);
1707 mark (SCHEME_V->code);
1708 dump_stack_mark (SCHEME_A);
1709 mark (SCHEME_V->value);
1710 mark (SCHEME_V->inport);
1711 mark (SCHEME_V->save_inport);
1712 mark (SCHEME_V->outport);
1713 mark (SCHEME_V->loadport);
1714
1715 /* Mark recent objects the interpreter doesn't know about yet. */
1716 mark (car (S_SINK));
1717 /* Mark any older stuff above nested C calls */
1718 mark (SCHEME_V->c_nest);
1719
1720#if USE_INTCACHE
1721 /* mark intcache */
1722 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1723 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1724 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1701#endif 1725#endif
1726
1727 /* mark variables a, b */
1728 mark (a);
1729 mark (b);
1730
1731 /* garbage collect */
1732 clrmark (NIL);
1733 SCHEME_V->fcells = 0;
1734 SCHEME_V->free_cell = NIL;
1735
1736 if (SCHEME_V->gc_verbose)
1737 putstr (SCHEME_A_ "freeing...");
1738
1739 gc_free (SCHEME_A);
1702} 1740}
1703 1741
1704/* ========== Routines for Reading ========== */ 1742/* ========== Routines for Reading ========== */
1705 1743
1706static int 1744ecb_cold static int
1707file_push (SCHEME_P_ const char *fname) 1745file_push (SCHEME_P_ const char *fname)
1708{ 1746{
1709#if USE_PORTS
1710 int fin; 1747 int fin;
1711 1748
1712 if (SCHEME_V->file_i == MAXFIL - 1) 1749 if (SCHEME_V->file_i == MAXFIL - 1)
1713 return 0; 1750 return 0;
1714 1751
… …
1731 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0); 1768 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1732#endif 1769#endif
1733 } 1770 }
1734 1771
1735 return fin >= 0; 1772 return fin >= 0;
1736
1737#else
1738 return 1;
1739#endif
1740} 1773}
1741 1774
1742static void 1775ecb_cold static void
1743file_pop (SCHEME_P) 1776file_pop (SCHEME_P)
1744{ 1777{
1745 if (SCHEME_V->file_i != 0) 1778 if (SCHEME_V->file_i != 0)
1746 { 1779 {
1747 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1780 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
… …
1751 SCHEME_V->file_i--; 1784 SCHEME_V->file_i--;
1752 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i); 1785 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1753 } 1786 }
1754} 1787}
1755 1788
1756static int 1789ecb_cold static int
1757file_interactive (SCHEME_P) 1790file_interactive (SCHEME_P)
1758{ 1791{
1759#if USE_PORTS 1792#if USE_PORTS
1760 return SCHEME_V->file_i == 0 1793 return SCHEME_V->file_i == 0
1761 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1794 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
… …
1764 return 0; 1797 return 0;
1765#endif 1798#endif
1766} 1799}
1767 1800
1768#if USE_PORTS 1801#if USE_PORTS
1769static port * 1802ecb_cold static port *
1770port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1803port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1771{ 1804{
1772 int fd; 1805 int fd;
1773 int flags; 1806 int flags;
1774 char *rw; 1807 char *rw;
… …
1797# endif 1830# endif
1798 1831
1799 return pt; 1832 return pt;
1800} 1833}
1801 1834
1802static pointer 1835ecb_cold static pointer
1803port_from_filename (SCHEME_P_ const char *fn, int prop) 1836port_from_filename (SCHEME_P_ const char *fn, int prop)
1804{ 1837{
1805 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1838 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1806 1839
1807 if (!pt && USE_ERROR_CHECKING) 1840 if (!pt && USE_ERROR_CHECKING)
1808 return NIL; 1841 return NIL;
1809 1842
1810 return mk_port (SCHEME_A_ pt); 1843 return mk_port (SCHEME_A_ pt);
1811} 1844}
1812 1845
1813static port * 1846ecb_cold static port *
1814port_rep_from_file (SCHEME_P_ int f, int prop) 1847port_rep_from_file (SCHEME_P_ int f, int prop)
1815{ 1848{
1816 port *pt = malloc (sizeof *pt); 1849 port *pt = malloc (sizeof *pt);
1817 1850
1818 if (!pt && USE_ERROR_CHECKING) 1851 if (!pt && USE_ERROR_CHECKING)
… …
1823 pt->rep.stdio.file = f; 1856 pt->rep.stdio.file = f;
1824 pt->rep.stdio.closeit = 0; 1857 pt->rep.stdio.closeit = 0;
1825 return pt; 1858 return pt;
1826} 1859}
1827 1860
1828static pointer 1861ecb_cold static pointer
1829port_from_file (SCHEME_P_ int f, int prop) 1862port_from_file (SCHEME_P_ int f, int prop)
1830{ 1863{
1831 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1864 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1832 1865
1833 if (!pt && USE_ERROR_CHECKING) 1866 if (!pt && USE_ERROR_CHECKING)
1834 return NIL; 1867 return NIL;
1835 1868
1836 return mk_port (SCHEME_A_ pt); 1869 return mk_port (SCHEME_A_ pt);
1837} 1870}
1838 1871
1839static port * 1872ecb_cold static port *
1840port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1873port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1841{ 1874{
1842 port *pt = malloc (sizeof (port)); 1875 port *pt = malloc (sizeof (port));
1843 1876
1844 if (!pt && USE_ERROR_CHECKING) 1877 if (!pt && USE_ERROR_CHECKING)
… …
1850 pt->rep.string.curr = start; 1883 pt->rep.string.curr = start;
1851 pt->rep.string.past_the_end = past_the_end; 1884 pt->rep.string.past_the_end = past_the_end;
1852 return pt; 1885 return pt;
1853} 1886}
1854 1887
1855static pointer 1888ecb_cold static pointer
1856port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1889port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1857{ 1890{
1858 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1891 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1859 1892
1860 if (!pt && USE_ERROR_CHECKING) 1893 if (!pt && USE_ERROR_CHECKING)
… …
1863 return mk_port (SCHEME_A_ pt); 1896 return mk_port (SCHEME_A_ pt);
1864} 1897}
1865 1898
1866# define BLOCK_SIZE 256 1899# define BLOCK_SIZE 256
1867 1900
1868static port * 1901ecb_cold static port *
1869port_rep_from_scratch (SCHEME_P) 1902port_rep_from_scratch (SCHEME_P)
1870{ 1903{
1871 char *start; 1904 char *start;
1872 port *pt = malloc (sizeof (port)); 1905 port *pt = malloc (sizeof (port));
1873 1906
… …
1887 pt->rep.string.curr = start; 1920 pt->rep.string.curr = start;
1888 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1921 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1889 return pt; 1922 return pt;
1890} 1923}
1891 1924
1892static pointer 1925ecb_cold static pointer
1893port_from_scratch (SCHEME_P) 1926port_from_scratch (SCHEME_P)
1894{ 1927{
1895 port *pt = port_rep_from_scratch (SCHEME_A); 1928 port *pt = port_rep_from_scratch (SCHEME_A);
1896 1929
1897 if (!pt && USE_ERROR_CHECKING) 1930 if (!pt && USE_ERROR_CHECKING)
1898 return NIL; 1931 return NIL;
1899 1932
1900 return mk_port (SCHEME_A_ pt); 1933 return mk_port (SCHEME_A_ pt);
1901} 1934}
1902 1935
1903static void 1936ecb_cold static void
1904port_close (SCHEME_P_ pointer p, int flag) 1937port_close (SCHEME_P_ pointer p, int flag)
1905{ 1938{
1906 port *pt = port (p); 1939 port *pt = port (p);
1907 1940
1908 pt->kind &= ~flag; 1941 pt->kind &= ~flag;
… …
1928 } 1961 }
1929} 1962}
1930#endif 1963#endif
1931 1964
1932/* get new character from input file */ 1965/* get new character from input file */
1933static int 1966ecb_cold static int
1934inchar (SCHEME_P) 1967inchar (SCHEME_P)
1935{ 1968{
1936 int c; 1969 int c;
1937 port *pt = port (SCHEME_V->inport); 1970 port *pt = port (SCHEME_V->inport);
1938 1971
… …
1952 } 1985 }
1953 1986
1954 return c; 1987 return c;
1955} 1988}
1956 1989
1957static int ungot = -1; 1990ecb_cold static int
1958
1959static int
1960basic_inchar (port *pt) 1991basic_inchar (port *pt)
1961{ 1992{
1962#if USE_PORTS
1963 if (pt->unget != -1) 1993 if (pt->unget != -1)
1964 { 1994 {
1965 int r = pt->unget; 1995 int r = pt->unget;
1966 pt->unget = -1; 1996 pt->unget = -1;
1967 return r; 1997 return r;
1968 } 1998 }
1969 1999
2000#if USE_PORTS
1970 if (pt->kind & port_file) 2001 if (pt->kind & port_file)
1971 { 2002 {
1972 char c; 2003 char c;
1973 2004
1974 if (!read (pt->rep.stdio.file, &c, 1)) 2005 if (!read (pt->rep.stdio.file, &c, 1))
… …
1982 return EOF; 2013 return EOF;
1983 else 2014 else
1984 return *pt->rep.string.curr++; 2015 return *pt->rep.string.curr++;
1985 } 2016 }
1986#else 2017#else
1987 if (ungot == -1)
1988 {
1989 char c; 2018 char c;
1990 if (!read (0, &c, 1)) 2019
2020 if (!read (pt->rep.stdio.file, &c, 1))
1991 return EOF; 2021 return EOF;
1992 2022
1993 ungot = c;
1994 }
1995
1996 {
1997 int r = ungot;
1998 ungot = -1;
1999 return r; 2023 return c;
2000 }
2001#endif 2024#endif
2002} 2025}
2003 2026
2004/* back character to input buffer */ 2027/* back character to input buffer */
2005static void 2028ecb_cold static void
2006backchar (SCHEME_P_ int c) 2029backchar (SCHEME_P_ int c)
2007{ 2030{
2008#if USE_PORTS 2031 port *pt = port (SCHEME_V->inport);
2009 port *pt;
2010 2032
2011 if (c == EOF) 2033 if (c == EOF)
2012 return; 2034 return;
2013 2035
2014 pt = port (SCHEME_V->inport);
2015 pt->unget = c; 2036 pt->unget = c;
2016#else
2017 if (c == EOF)
2018 return;
2019
2020 ungot = c;
2021#endif
2022} 2037}
2023 2038
2024#if USE_PORTS 2039#if USE_PORTS
2025static int 2040ecb_cold static int
2026realloc_port_string (SCHEME_P_ port *p) 2041realloc_port_string (SCHEME_P_ port *p)
2027{ 2042{
2028 char *start = p->rep.string.start; 2043 char *start = p->rep.string.start;
2029 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2044 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2030 char *str = malloc (new_size); 2045 char *str = malloc (new_size);
… …
2043 else 2058 else
2044 return 0; 2059 return 0;
2045} 2060}
2046#endif 2061#endif
2047 2062
2048INTERFACE void 2063ecb_cold static void
2049putstr (SCHEME_P_ const char *s) 2064putchars (SCHEME_P_ const char *s, int len)
2050{ 2065{
2066 port *pt = port (SCHEME_V->outport);
2067
2051#if USE_PORTS 2068#if USE_PORTS
2052 port *pt = port (SCHEME_V->outport);
2053
2054 if (pt->kind & port_file)
2055 write (pt->rep.stdio.file, s, strlen (s));
2056 else
2057 for (; *s; s++)
2058 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2059 *pt->rep.string.curr++ = *s;
2060 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2061 *pt->rep.string.curr++ = *s;
2062
2063#else
2064 write (pt->rep.stdio.file, s, strlen (s));
2065#endif
2066}
2067
2068static void
2069putchars (SCHEME_P_ const char *s, int len)
2070{
2071#if USE_PORTS
2072 port *pt = port (SCHEME_V->outport);
2073
2074 if (pt->kind & port_file) 2069 if (pt->kind & port_file)
2075 write (pt->rep.stdio.file, s, len); 2070 write (pt->rep.stdio.file, s, len);
2076 else 2071 else
2077 { 2072 {
2078 for (; len; len--) 2073 for (; len; len--)
… …
2083 *pt->rep.string.curr++ = *s++; 2078 *pt->rep.string.curr++ = *s++;
2084 } 2079 }
2085 } 2080 }
2086 2081
2087#else 2082#else
2088 write (1, s, len); 2083 write (1, s, len); // output not initialised
2089#endif 2084#endif
2085}
2086
2087INTERFACE void
2088putstr (SCHEME_P_ const char *s)
2089{
2090 putchars (SCHEME_A_ s, strlen (s));
2090} 2091}
2091 2092
2092INTERFACE void 2093INTERFACE void
2093putcharacter (SCHEME_P_ int c) 2094putcharacter (SCHEME_P_ int c)
2094{ 2095{
2095#if USE_PORTS
2096 port *pt = port (SCHEME_V->outport);
2097
2098 if (pt->kind & port_file)
2099 {
2100 char cc = c;
2101 write (pt->rep.stdio.file, &cc, 1);
2102 }
2103 else
2104 {
2105 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2106 *pt->rep.string.curr++ = c;
2107 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2108 *pt->rep.string.curr++ = c;
2109 }
2110
2111#else
2112 char cc = c; 2096 char cc = c;
2113 write (1, &c, 1); 2097
2114#endif 2098 putchars (SCHEME_A_ &cc, 1);
2115} 2099}
2116 2100
2117/* read characters up to delimiter, but cater to character constants */ 2101/* read characters up to delimiter, but cater to character constants */
2118static char * 2102ecb_cold static char *
2119readstr_upto (SCHEME_P_ int skip, const char *delim) 2103readstr_upto (SCHEME_P_ int skip, const char *delim)
2120{ 2104{
2121 char *p = SCHEME_V->strbuff + skip; 2105 char *p = SCHEME_V->strbuff + skip;
2122 2106
2123 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2107 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
… …
2132 2116
2133 return SCHEME_V->strbuff; 2117 return SCHEME_V->strbuff;
2134} 2118}
2135 2119
2136/* read string expression "xxx...xxx" */ 2120/* read string expression "xxx...xxx" */
2137static pointer 2121ecb_cold static pointer
2138readstrexp (SCHEME_P_ char delim) 2122readstrexp (SCHEME_P_ char delim)
2139{ 2123{
2140 char *p = SCHEME_V->strbuff; 2124 char *p = SCHEME_V->strbuff;
2141 int c; 2125 int c;
2142 int c1 = 0; 2126 int c1 = 0;
… …
2175 case '7': 2159 case '7':
2176 state = st_oct1; 2160 state = st_oct1;
2177 c1 = c - '0'; 2161 c1 = c - '0';
2178 break; 2162 break;
2179 2163
2164 case 'a': *p++ = '\a'; state = st_ok; break;
2165 case 'n': *p++ = '\n'; state = st_ok; break;
2166 case 'r': *p++ = '\r'; state = st_ok; break;
2167 case 't': *p++ = '\t'; state = st_ok; break;
2168
2169 case '\\':
2170 skipspace (SCHEME_A);
2171 break;
2172
2173 //TODO: x should end in ;, not two-digit hex
2180 case 'x': 2174 case 'x':
2181 case 'X': 2175 case 'X':
2182 state = st_x1; 2176 state = st_x1;
2183 c1 = 0; 2177 c1 = 0;
2184 break;
2185
2186 case 'n':
2187 *p++ = '\n';
2188 state = st_ok;
2189 break;
2190
2191 case 't':
2192 *p++ = '\t';
2193 state = st_ok;
2194 break;
2195
2196 case 'r':
2197 *p++ = '\r';
2198 state = st_ok;
2199 break; 2178 break;
2200 2179
2201 default: 2180 default:
2202 *p++ = c; 2181 *p++ = c;
2203 state = st_ok; 2182 state = st_ok;
… …
2255 } 2234 }
2256 } 2235 }
2257} 2236}
2258 2237
2259/* check c is in chars */ 2238/* check c is in chars */
2260ecb_inline int 2239ecb_cold int
2261is_one_of (const char *s, int c) 2240is_one_of (const char *s, int c)
2262{ 2241{
2263 return c == EOF || !!strchr (s, c); 2242 return c == EOF || !!strchr (s, c);
2264} 2243}
2265 2244
2266/* skip white characters */ 2245/* skip white characters */
2267ecb_inline int 2246ecb_cold int
2268skipspace (SCHEME_P) 2247skipspace (SCHEME_P)
2269{ 2248{
2270 int c, curr_line = 0; 2249 int c, curr_line = 0;
2271 2250
2272 do 2251 do
… …
2292 backchar (SCHEME_A_ c); 2271 backchar (SCHEME_A_ c);
2293 return 1; 2272 return 1;
2294} 2273}
2295 2274
2296/* get token */ 2275/* get token */
2297static int 2276ecb_cold static int
2298token (SCHEME_P) 2277token (SCHEME_P)
2299{ 2278{
2300 int c = skipspace (SCHEME_A); 2279 int c = skipspace (SCHEME_A);
2301 2280
2302 if (c == EOF) 2281 if (c == EOF)
… …
2400} 2379}
2401 2380
2402/* ========== Routines for Printing ========== */ 2381/* ========== Routines for Printing ========== */
2403#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2382#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2404 2383
2405static void 2384ecb_cold static void
2406printslashstring (SCHEME_P_ char *p, int len) 2385printslashstring (SCHEME_P_ char *p, int len)
2407{ 2386{
2408 int i; 2387 int i;
2409 unsigned char *s = (unsigned char *) p; 2388 unsigned char *s = (unsigned char *) p;
2410 2389
… …
2466 2445
2467 putcharacter (SCHEME_A_ '"'); 2446 putcharacter (SCHEME_A_ '"');
2468} 2447}
2469 2448
2470/* print atoms */ 2449/* print atoms */
2471static void 2450ecb_cold static void
2472printatom (SCHEME_P_ pointer l, int f) 2451printatom (SCHEME_P_ pointer l, int f)
2473{ 2452{
2474 char *p; 2453 char *p;
2475 int len; 2454 int len;
2476 2455
2477 atom2str (SCHEME_A_ l, f, &p, &len); 2456 atom2str (SCHEME_A_ l, f, &p, &len);
2478 putchars (SCHEME_A_ p, len); 2457 putchars (SCHEME_A_ p, len);
2479} 2458}
2480 2459
2481/* Uses internal buffer unless string pointer is already available */ 2460/* Uses internal buffer unless string pointer is already available */
2482static void 2461ecb_cold static void
2483atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2462atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2484{ 2463{
2485 char *p; 2464 char *p;
2486 2465
2487 if (l == NIL) 2466 if (l == NIL)
… …
2694 return car (d); 2673 return car (d);
2695 2674
2696 p = cons (car (d), cdr (d)); 2675 p = cons (car (d), cdr (d));
2697 q = p; 2676 q = p;
2698 2677
2699 while (cdr (cdr (p)) != NIL) 2678 while (cddr (p) != NIL)
2700 { 2679 {
2701 d = cons (car (p), cdr (p)); 2680 d = cons (car (p), cdr (p));
2702 2681
2703 if (cdr (cdr (p)) != NIL) 2682 if (cddr (p) != NIL)
2704 p = cdr (d); 2683 p = cdr (d);
2705 } 2684 }
2706 2685
2707 set_cdr (p, car (cdr (p))); 2686 set_cdr (p, cadr (p));
2708 return q; 2687 return q;
2709} 2688}
2710 2689
2711/* reverse list -- produce new list */ 2690/* reverse list -- produce new list */
2712static pointer 2691ecb_hot static pointer
2713reverse (SCHEME_P_ pointer a) 2692reverse (SCHEME_P_ pointer a)
2714{ 2693{
2715 /* a must be checked by gc */ 2694 /* a must be checked by gc */
2716 pointer p = NIL; 2695 pointer p = NIL;
2717 2696
… …
2720 2699
2721 return p; 2700 return p;
2722} 2701}
2723 2702
2724/* reverse list --- in-place */ 2703/* reverse list --- in-place */
2725static pointer 2704ecb_hot static pointer
2726reverse_in_place (SCHEME_P_ pointer term, pointer list) 2705reverse_in_place (SCHEME_P_ pointer term, pointer list)
2727{ 2706{
2728 pointer result = term; 2707 pointer result = term;
2729 pointer p = list; 2708 pointer p = list;
2730 2709
… …
2738 2717
2739 return result; 2718 return result;
2740} 2719}
2741 2720
2742/* append list -- produce new list (in reverse order) */ 2721/* append list -- produce new list (in reverse order) */
2743static pointer 2722ecb_hot static pointer
2744revappend (SCHEME_P_ pointer a, pointer b) 2723revappend (SCHEME_P_ pointer a, pointer b)
2745{ 2724{
2746 pointer result = a; 2725 pointer result = a;
2747 pointer p = b; 2726 pointer p = b;
2748 2727
… …
2757 2736
2758 return S_F; /* signal an error */ 2737 return S_F; /* signal an error */
2759} 2738}
2760 2739
2761/* equivalence of atoms */ 2740/* equivalence of atoms */
2762int 2741ecb_hot int
2763eqv (pointer a, pointer b) 2742eqv (pointer a, pointer b)
2764{ 2743{
2765 if (is_string (a)) 2744 if (is_string (a))
2766 { 2745 {
2767 if (is_string (b)) 2746 if (is_string (b))
… …
2861 } 2840 }
2862 else 2841 else
2863 set_car (env, immutable_cons (slot, car (env))); 2842 set_car (env, immutable_cons (slot, car (env)));
2864} 2843}
2865 2844
2866static pointer 2845ecb_hot static pointer
2867find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2846find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2868{ 2847{
2869 pointer x, y; 2848 pointer x, y;
2870 2849
2871 for (x = env; x != NIL; x = cdr (x)) 2850 for (x = env; x != NIL; x = cdr (x))
… …
2892 return NIL; 2871 return NIL;
2893} 2872}
2894 2873
2895#else /* USE_ALIST_ENV */ 2874#else /* USE_ALIST_ENV */
2896 2875
2897ecb_inline void 2876static void
2898new_frame_in_env (SCHEME_P_ pointer old_env) 2877new_frame_in_env (SCHEME_P_ pointer old_env)
2899{ 2878{
2900 SCHEME_V->envir = immutable_cons (NIL, old_env); 2879 SCHEME_V->envir = immutable_cons (NIL, old_env);
2901 setenvironment (SCHEME_V->envir); 2880 setenvironment (SCHEME_V->envir);
2902} 2881}
2903 2882
2904ecb_inline void 2883static void
2905new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2884new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2906{ 2885{
2907 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2886 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2908} 2887}
2909 2888
2910static pointer 2889ecb_hot static pointer
2911find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2890find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2912{ 2891{
2913 pointer x, y; 2892 pointer x, y;
2914 2893
2915 for (x = env; x != NIL; x = cdr (x)) 2894 for (x = env; x != NIL; x = cdr (x))
… …
2929 return NIL; 2908 return NIL;
2930} 2909}
2931 2910
2932#endif /* USE_ALIST_ENV else */ 2911#endif /* USE_ALIST_ENV else */
2933 2912
2934ecb_inline void 2913static void
2935new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2914new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2936{ 2915{
2937 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 2916 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2938 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2917 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2939} 2918}
2940 2919
2941ecb_inline void 2920static void
2942set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2921set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2943{ 2922{
2944 set_cdr (slot, value); 2923 set_cdr (slot, value);
2945} 2924}
2946 2925
2947ecb_inline pointer 2926static pointer
2948slot_value_in_env (pointer slot) 2927slot_value_in_env (pointer slot)
2949{ 2928{
2950 return cdr (slot); 2929 return cdr (slot);
2951} 2930}
2952 2931
2953/* ========== Evaluation Cycle ========== */ 2932/* ========== Evaluation Cycle ========== */
2954 2933
2955static int 2934ecb_cold static int
2956xError_1 (SCHEME_P_ const char *s, pointer a) 2935xError_1 (SCHEME_P_ const char *s, pointer a)
2957{ 2936{
2958#if USE_ERROR_HOOK 2937#if USE_ERROR_HOOK
2959 pointer x; 2938 pointer x;
2960 pointer hdl = SCHEME_V->ERROR_HOOK; 2939 pointer hdl = SCHEME_V->ERROR_HOOK;
… …
3036 pointer code; 3015 pointer code;
3037}; 3016};
3038 3017
3039# define STACK_GROWTH 3 3018# define STACK_GROWTH 3
3040 3019
3041static void 3020ecb_hot static void
3042s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3021s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3043{ 3022{
3044 int nframes = (uintptr_t)SCHEME_V->dump; 3023 int nframes = (uintptr_t)SCHEME_V->dump;
3045 struct dump_stack_frame *next_frame; 3024 struct dump_stack_frame *next_frame;
3046 3025
… …
3059 next_frame->code = code; 3038 next_frame->code = code;
3060 3039
3061 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3040 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3062} 3041}
3063 3042
3064static int 3043static ecb_hot int
3065xs_return (SCHEME_P_ pointer a) 3044xs_return (SCHEME_P_ pointer a)
3066{ 3045{
3067 int nframes = (uintptr_t)SCHEME_V->dump; 3046 int nframes = (uintptr_t)SCHEME_V->dump;
3068 struct dump_stack_frame *frame; 3047 struct dump_stack_frame *frame;
3069 3048
… …
3080 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3059 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3081 3060
3082 return 0; 3061 return 0;
3083} 3062}
3084 3063
3085ecb_inline void 3064ecb_cold void
3086dump_stack_reset (SCHEME_P) 3065dump_stack_reset (SCHEME_P)
3087{ 3066{
3088 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3067 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3089 SCHEME_V->dump = (pointer)+0; 3068 SCHEME_V->dump = (pointer)+0;
3090} 3069}
3091 3070
3092ecb_inline void 3071ecb_cold void
3093dump_stack_initialize (SCHEME_P) 3072dump_stack_initialize (SCHEME_P)
3094{ 3073{
3095 SCHEME_V->dump_size = 0; 3074 SCHEME_V->dump_size = 0;
3096 SCHEME_V->dump_base = 0; 3075 SCHEME_V->dump_base = 0;
3097 dump_stack_reset (SCHEME_A); 3076 dump_stack_reset (SCHEME_A);
3098} 3077}
3099 3078
3100static void 3079ecb_cold static void
3101dump_stack_free (SCHEME_P) 3080dump_stack_free (SCHEME_P)
3102{ 3081{
3103 free (SCHEME_V->dump_base); 3082 free (SCHEME_V->dump_base);
3104 SCHEME_V->dump_base = 0; 3083 SCHEME_V->dump_base = 0;
3105 SCHEME_V->dump = (pointer)0; 3084 SCHEME_V->dump = (pointer)0;
3106 SCHEME_V->dump_size = 0; 3085 SCHEME_V->dump_size = 0;
3107} 3086}
3108 3087
3109static void 3088ecb_cold static void
3110dump_stack_mark (SCHEME_P) 3089dump_stack_mark (SCHEME_P)
3111{ 3090{
3112 int nframes = (uintptr_t)SCHEME_V->dump; 3091 int nframes = (uintptr_t)SCHEME_V->dump;
3113 int i; 3092 int i;
3114 3093
… …
3120 mark (frame->envir); 3099 mark (frame->envir);
3121 mark (frame->code); 3100 mark (frame->code);
3122 } 3101 }
3123} 3102}
3124 3103
3125static pointer 3104ecb_cold static pointer
3126ss_get_cont (SCHEME_P) 3105ss_get_cont (SCHEME_P)
3127{ 3106{
3128 int nframes = (uintptr_t)SCHEME_V->dump; 3107 int nframes = (uintptr_t)SCHEME_V->dump;
3129 int i; 3108 int i;
3130 3109
… …
3142 } 3121 }
3143 3122
3144 return cont; 3123 return cont;
3145} 3124}
3146 3125
3147static void 3126ecb_cold static void
3148ss_set_cont (SCHEME_P_ pointer cont) 3127ss_set_cont (SCHEME_P_ pointer cont)
3149{ 3128{
3150 int i = 0; 3129 int i = 0;
3151 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3130 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3152 3131
… …
3164 SCHEME_V->dump = (pointer)(uintptr_t)i; 3143 SCHEME_V->dump = (pointer)(uintptr_t)i;
3165} 3144}
3166 3145
3167#else 3146#else
3168 3147
3169ecb_inline void 3148ecb_cold void
3170dump_stack_reset (SCHEME_P) 3149dump_stack_reset (SCHEME_P)
3171{ 3150{
3172 SCHEME_V->dump = NIL; 3151 SCHEME_V->dump = NIL;
3173} 3152}
3174 3153
3175ecb_inline void 3154ecb_cold void
3176dump_stack_initialize (SCHEME_P) 3155dump_stack_initialize (SCHEME_P)
3177{ 3156{
3178 dump_stack_reset (SCHEME_A); 3157 dump_stack_reset (SCHEME_A);
3179} 3158}
3180 3159
3181static void 3160ecb_cold static void
3182dump_stack_free (SCHEME_P) 3161dump_stack_free (SCHEME_P)
3183{ 3162{
3184 SCHEME_V->dump = NIL; 3163 SCHEME_V->dump = NIL;
3185} 3164}
3186 3165
3187static int 3166ecb_hot static int
3188xs_return (SCHEME_P_ pointer a) 3167xs_return (SCHEME_P_ pointer a)
3189{ 3168{
3190 pointer dump = SCHEME_V->dump; 3169 pointer dump = SCHEME_V->dump;
3191 3170
3192 SCHEME_V->value = a; 3171 SCHEME_V->value = a;
… …
3202 SCHEME_V->dump = dump; 3181 SCHEME_V->dump = dump;
3203 3182
3204 return 0; 3183 return 0;
3205} 3184}
3206 3185
3207static void 3186ecb_hot static void
3208s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3187s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3209{ 3188{
3210 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3189 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3211 cons (args, 3190 cons (args,
3212 cons (SCHEME_V->envir, 3191 cons (SCHEME_V->envir,
3213 cons (code, 3192 cons (code,
3214 SCHEME_V->dump)))); 3193 SCHEME_V->dump))));
3215} 3194}
3216 3195
3196ecb_cold static void
3197dump_stack_mark (SCHEME_P)
3198{
3199 mark (SCHEME_V->dump);
3200}
3201
3202ecb_cold static pointer
3203ss_get_cont (SCHEME_P)
3204{
3205 return SCHEME_V->dump;
3206}
3207
3208ecb_cold static void
3209ss_set_cont (SCHEME_P_ pointer cont)
3210{
3211 SCHEME_V->dump = cont;
3212}
3213
3214#endif
3215
3216#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3217
3218#if EXPERIMENT
3219
3220typedef void *stream[1];
3221
3222#define stream_init() { 0 }
3223
3224ecb_cold static void
3225stream_put (void **s, uint8_t byte)
3226{
3227 uint32_t *sp = *s;
3228 uint32_t size = sizeof (uint32_t) * 2;
3229 uint32_t offs = size;
3230
3231 if (ecb_expect_true (sp))
3232 {
3233 offs = sp[0];
3234 size = sp[1];
3235 }
3236
3237 if (ecb_expect_false (offs == size))
3238 {
3239 size *= 2;
3240 sp = realloc (sp, size);
3241 *s = sp;
3242 sp[1] = size;
3243
3244 }
3245
3246 ((uint8_t *)sp)[offs++] = byte;
3247 sp[0] = offs;
3248}
3249
3250#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
3251#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
3252#define stream_free(s) free (s[0])
3253
3254// calculates a (preferably small) integer that makes it possible to find
3255// the symbol again. if pointers were offsets into a memory area... until
3256// then, we return segment number in the low bits, and offset in the high
3257// bits
3258static uint32_t
3259symbol_id (SCHEME_P_ pointer sym)
3260{
3261 struct cell *p = CELL (sym);
3262 int i;
3263
3264 for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3265 if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3266 {
3267 printf ("seg %d ofs %d/%d\n",i,(p - SCHEME_V->cell_seg[i]),SCHEME_V->cell_segsize[i]);//D
3268 return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3269 }
3270
3271 abort ();
3272}
3273
3217static void 3274static void
3218dump_stack_mark (SCHEME_P) 3275compile (SCHEME_P_ stream s, pointer x)
3219{ 3276{
3220 mark (SCHEME_V->dump); 3277 if (x == NIL)
3221} 3278 {
3279 stream_put (s, 0);
3280 return;
3281 }
3222 3282
3223static pointer 3283 if (is_syntax (x))
3224ss_get_cont (SCHEME_P) 3284 {
3225{ 3285 stream_put (s, 1);
3226 return SCHEME_V->dump; 3286 stream_put (s, syntaxnum (x));
3227} 3287 return;
3288 }
3228 3289
3229static void 3290 switch (type (x))
3230ss_set_cont (SCHEME_P_ pointer cont) 3291 {
3231{ 3292 case T_INTEGER:
3232 SCHEME_V->dump = cont; 3293 stream_put (s, 2);
3233} 3294 stream_put (s, 0);
3295 stream_put (s, 0);
3296 stream_put (s, 0);
3297 stream_put (s, 0);
3298 return;
3234 3299
3235#endif 3300 case T_SYMBOL:
3301 {
3302 uint32_t sym = symbol_id (SCHEME_A_ x);
3303 printf ("sym %x\n", sym);//D
3236 3304
3237#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3305 stream_put (s, 3);
3238 3306
3239#if EXPERIMENT 3307 while (sym > 0x7f)
3308 {
3309 stream_put (s, sym | 0x80);
3310 sym >>= 8;
3311 }
3312
3313 stream_put (s, sym);
3314 }
3315 return;
3316
3317 case T_PAIR:
3318 stream_put (s, 4);
3319 while (x != NIL)
3320 {
3321 compile (SCHEME_A_ s, car (x));
3322 x = cdr (x);
3323 }
3324 stream_put (s, 0xff);
3325 return;
3326
3327 default:
3328 stream_put (s, 5);
3329 stream_put (s, type (x));
3330 stream_put (s, 0);
3331 stream_put (s, 0);
3332 stream_put (s, 0);
3333 stream_put (s, 0);
3334 break;
3335 }
3336}
3337
3240static int 3338static int
3339compile_closure (SCHEME_P_ pointer p)
3340{
3341 stream s = stream_init ();
3342
3343 printatom (SCHEME_A_ p, 1);//D
3344 compile (SCHEME_A_ s, car (p));
3345
3346 FILE *xxd = popen ("xxd", "we");
3347 fwrite (stream_data (s), 1, stream_size (s), xxd);
3348 fclose (xxd);
3349
3350 return stream_size (s);
3351}
3352
3353static int
3241debug (SCHEME_P_ int indent, pointer x) 3354dtree (SCHEME_P_ int indent, pointer x)
3242{ 3355{
3243 int c; 3356 int c;
3244 3357
3245 if (is_syntax (x)) 3358 if (is_syntax (x))
3246 { 3359 {
… …
3264 printf ("%*sS<%s>\n", indent, "", symname (x)); 3377 printf ("%*sS<%s>\n", indent, "", symname (x));
3265 return 24+8; 3378 return 24+8;
3266 3379
3267 case T_CLOSURE: 3380 case T_CLOSURE:
3268 printf ("%*sS<%s>\n", indent, "", "closure"); 3381 printf ("%*sS<%s>\n", indent, "", "closure");
3269 debug (SCHEME_A_ indent + 3, cdr(x)); 3382 dtree (SCHEME_A_ indent + 3, cdr(x));
3270 return 32 + debug (SCHEME_A_ indent + 3, car (x)); 3383 return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3271 3384
3272 case T_PAIR: 3385 case T_PAIR:
3273 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); 3386 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3274 c = debug (SCHEME_A_ indent + 3, car (x)); 3387 c = dtree (SCHEME_A_ indent + 3, car (x));
3275 c += debug (SCHEME_A_ indent + 3, cdr (x)); 3388 c += dtree (SCHEME_A_ indent + 3, cdr (x));
3276 return c + 1; 3389 return c + 1;
3277 3390
3278 case T_PORT: 3391 case T_PORT:
3279 printf ("%*sS<%s>\n", indent, "", "port"); 3392 printf ("%*sS<%s>\n", indent, "", "port");
3280 return 24+8; 3393 return 24+8;
… …
3283 printf ("%*sS<%s>\n", indent, "", "vector"); 3396 printf ("%*sS<%s>\n", indent, "", "vector");
3284 return 24+8; 3397 return 24+8;
3285 3398
3286 case T_ENVIRONMENT: 3399 case T_ENVIRONMENT:
3287 printf ("%*sS<%s>\n", indent, "", "environment"); 3400 printf ("%*sS<%s>\n", indent, "", "environment");
3288 return 0 + debug (SCHEME_A_ indent + 3, car (x)); 3401 return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3289 3402
3290 default: 3403 default:
3291 printf ("unhandled type %d\n", type (x)); 3404 printf ("unhandled type %d\n", type (x));
3292 break; 3405 break;
3293 } 3406 }
3294} 3407}
3295#endif 3408#endif
3296 3409
3297static int 3410/* syntax, eval, core, ... */
3411ecb_hot static int
3298opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3412opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3299{ 3413{
3300 pointer args = SCHEME_V->args; 3414 pointer args = SCHEME_V->args;
3301 pointer x, y; 3415 pointer x, y;
3302 3416
3303 switch (op) 3417 switch (op)
3304 { 3418 {
3305#if EXPERIMENT //D 3419#if EXPERIMENT //D
3306 case OP_DEBUG: 3420 case OP_DEBUG:
3307 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3421 {
3422 uint32_t len = compile_closure (SCHEME_A_ car (args));
3423 printf ("len = %d\n", len);
3308 printf ("\n"); 3424 printf ("\n");
3309 s_return (S_T); 3425 s_return (S_T);
3426 }
3310#endif 3427#endif
3311 case OP_LOAD: /* load */ 3428 case OP_LOAD: /* load */
3312 if (file_interactive (SCHEME_A)) 3429 if (file_interactive (SCHEME_A))
3313 { 3430 {
3314 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n"); 3431 putstr (SCHEME_A_ "Loading ");
3315 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3432 putstr (SCHEME_A_ strvalue (car (args)));
3433 putcharacter (SCHEME_A_ '\n');
3316 } 3434 }
3317 3435
3318 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3436 if (!file_push (SCHEME_A_ strvalue (car (args))))
3319 Error_1 ("unable to open", car (args)); 3437 Error_1 ("unable to open", car (args));
3320 else 3438
3321 {
3322 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3439 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3323 s_goto (OP_T0LVL); 3440 s_goto (OP_T0LVL);
3324 }
3325 3441
3326 case OP_T0LVL: /* top level */ 3442 case OP_T0LVL: /* top level */
3327 3443
3328 /* If we reached the end of file, this loop is done. */ 3444 /* If we reached the end of file, this loop is done. */
3329 if (port (SCHEME_V->loadport)->kind & port_saw_EOF) 3445 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
… …
3345 /* If interactive, be nice to user. */ 3461 /* If interactive, be nice to user. */
3346 if (file_interactive (SCHEME_A)) 3462 if (file_interactive (SCHEME_A))
3347 { 3463 {
3348 SCHEME_V->envir = SCHEME_V->global_env; 3464 SCHEME_V->envir = SCHEME_V->global_env;
3349 dump_stack_reset (SCHEME_A); 3465 dump_stack_reset (SCHEME_A);
3350 putstr (SCHEME_A_ "\n"); 3466 putcharacter (SCHEME_A_ '\n');
3351 putstr (SCHEME_A_ prompt); 3467 putstr (SCHEME_A_ prompt);
3352 } 3468 }
3353 3469
3354 /* Set up another iteration of REPL */ 3470 /* Set up another iteration of REPL */
3355 SCHEME_V->nesting = 0; 3471 SCHEME_V->nesting = 0;
… …
3390 { 3506 {
3391 SCHEME_V->print_flag = 1; 3507 SCHEME_V->print_flag = 1;
3392 SCHEME_V->args = SCHEME_V->value; 3508 SCHEME_V->args = SCHEME_V->value;
3393 s_goto (OP_P0LIST); 3509 s_goto (OP_P0LIST);
3394 } 3510 }
3395 else 3511
3396 s_return (SCHEME_V->value); 3512 s_return (SCHEME_V->value);
3397 3513
3398 case OP_EVAL: /* main part of evaluation */ 3514 case OP_EVAL: /* main part of evaluation */
3399#if USE_TRACING 3515#if USE_TRACING
3400 if (SCHEME_V->tracing) 3516 if (SCHEME_V->tracing)
3401 { 3517 {
… …
3434 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3550 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3435 SCHEME_V->code = x; 3551 SCHEME_V->code = x;
3436 s_goto (OP_EVAL); 3552 s_goto (OP_EVAL);
3437 } 3553 }
3438 } 3554 }
3439 else 3555
3440 s_return (SCHEME_V->code); 3556 s_return (SCHEME_V->code);
3441 3557
3442 case OP_E0ARGS: /* eval arguments */ 3558 case OP_E0ARGS: /* eval arguments */
3443 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ 3559 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3444 { 3560 {
3445 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3561 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
… …
3617 else 3733 else
3618 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 3734 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3619 3735
3620 s_return (SCHEME_V->code); 3736 s_return (SCHEME_V->code);
3621 3737
3622
3623 case OP_DEFP: /* defined? */ 3738 case OP_DEFP: /* defined? */
3624 x = SCHEME_V->envir; 3739 x = SCHEME_V->envir;
3625 3740
3626 if (cdr (args) != NIL) 3741 if (cdr (args) != NIL)
3627 x = cadr (args); 3742 x = cadr (args);
… …
3644 set_slot_in_env (SCHEME_A_ y, SCHEME_V->value); 3759 set_slot_in_env (SCHEME_A_ y, SCHEME_V->value);
3645 s_return (SCHEME_V->value); 3760 s_return (SCHEME_V->value);
3646 } 3761 }
3647 else 3762 else
3648 Error_1 ("set!: unbound variable:", SCHEME_V->code); 3763 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3649
3650 3764
3651 case OP_BEGIN: /* begin */ 3765 case OP_BEGIN: /* begin */
3652 if (!is_pair (SCHEME_V->code)) 3766 if (!is_pair (SCHEME_V->code))
3653 s_return (SCHEME_V->code); 3767 s_return (SCHEME_V->code);
3654 3768
… …
3666 case OP_IF1: /* if */ 3780 case OP_IF1: /* if */
3667 if (is_true (SCHEME_V->value)) 3781 if (is_true (SCHEME_V->value))
3668 SCHEME_V->code = car (SCHEME_V->code); 3782 SCHEME_V->code = car (SCHEME_V->code);
3669 else 3783 else
3670 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ 3784 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3785
3671 s_goto (OP_EVAL); 3786 s_goto (OP_EVAL);
3672 3787
3673 case OP_LET0: /* let */ 3788 case OP_LET0: /* let */
3674 SCHEME_V->args = NIL; 3789 SCHEME_V->args = NIL;
3675 SCHEME_V->value = SCHEME_V->code; 3790 SCHEME_V->value = SCHEME_V->code;
… …
3831 } 3946 }
3832 else 3947 else
3833 { 3948 {
3834 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) 3949 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3835 s_return (NIL); 3950 s_return (NIL);
3836 else 3951
3837 {
3838 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 3952 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3839 SCHEME_V->code = caar (SCHEME_V->code); 3953 SCHEME_V->code = caar (SCHEME_V->code);
3840 s_goto (OP_EVAL); 3954 s_goto (OP_EVAL);
3841 }
3842 } 3955 }
3843 3956
3844 case OP_DELAY: /* delay */ 3957 case OP_DELAY: /* delay */
3845 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 3958 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3846 set_typeflag (x, T_PROMISE); 3959 set_typeflag (x, T_PROMISE);
… …
3857 case OP_AND1: /* and */ 3970 case OP_AND1: /* and */
3858 if (is_false (SCHEME_V->value)) 3971 if (is_false (SCHEME_V->value))
3859 s_return (SCHEME_V->value); 3972 s_return (SCHEME_V->value);
3860 else if (SCHEME_V->code == NIL) 3973 else if (SCHEME_V->code == NIL)
3861 s_return (SCHEME_V->value); 3974 s_return (SCHEME_V->value);
3862 else 3975
3863 {
3864 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 3976 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3865 SCHEME_V->code = car (SCHEME_V->code); 3977 SCHEME_V->code = car (SCHEME_V->code);
3866 s_goto (OP_EVAL); 3978 s_goto (OP_EVAL);
3867 }
3868 3979
3869 case OP_OR0: /* or */ 3980 case OP_OR0: /* or */
3870 if (SCHEME_V->code == NIL) 3981 if (SCHEME_V->code == NIL)
3871 s_return (S_F); 3982 s_return (S_F);
3872 3983
… …
3877 case OP_OR1: /* or */ 3988 case OP_OR1: /* or */
3878 if (is_true (SCHEME_V->value)) 3989 if (is_true (SCHEME_V->value))
3879 s_return (SCHEME_V->value); 3990 s_return (SCHEME_V->value);
3880 else if (SCHEME_V->code == NIL) 3991 else if (SCHEME_V->code == NIL)
3881 s_return (SCHEME_V->value); 3992 s_return (SCHEME_V->value);
3882 else 3993
3883 {
3884 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 3994 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3885 SCHEME_V->code = car (SCHEME_V->code); 3995 SCHEME_V->code = car (SCHEME_V->code);
3886 s_goto (OP_EVAL); 3996 s_goto (OP_EVAL);
3887 }
3888 3997
3889 case OP_C0STREAM: /* cons-stream */ 3998 case OP_C0STREAM: /* cons-stream */
3890 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 3999 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3891 SCHEME_V->code = car (SCHEME_V->code); 4000 SCHEME_V->code = car (SCHEME_V->code);
3892 s_goto (OP_EVAL); 4001 s_goto (OP_EVAL);
… …
3957 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x)); 4066 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3958 SCHEME_V->code = caar (x); 4067 SCHEME_V->code = caar (x);
3959 s_goto (OP_EVAL); 4068 s_goto (OP_EVAL);
3960 } 4069 }
3961 } 4070 }
3962 else 4071
3963 s_return (NIL); 4072 s_return (NIL);
3964 4073
3965 case OP_CASE2: /* case */ 4074 case OP_CASE2: /* case */
3966 if (is_true (SCHEME_V->value)) 4075 if (is_true (SCHEME_V->value))
3967 s_goto (OP_BEGIN); 4076 s_goto (OP_BEGIN);
3968 else 4077
3969 s_return (NIL); 4078 s_return (NIL);
3970 4079
3971 case OP_PAPPLY: /* apply */ 4080 case OP_PAPPLY: /* apply */
3972 SCHEME_V->code = car (args); 4081 SCHEME_V->code = car (args);
3973 SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); 4082 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3974 /*SCHEME_V->args = cadr(args); */ 4083 /*SCHEME_V->args = cadr(args); */
… …
3988 } 4097 }
3989 4098
3990 if (USE_ERROR_CHECKING) abort (); 4099 if (USE_ERROR_CHECKING) abort ();
3991} 4100}
3992 4101
3993static int 4102/* math, cxr */
4103ecb_hot static int
3994opexe_1 (SCHEME_P_ enum scheme_opcodes op) 4104opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3995{ 4105{
3996 pointer args = SCHEME_V->args; 4106 pointer args = SCHEME_V->args;
3997 pointer x = car (args); 4107 pointer x = car (args);
3998 num v; 4108 num v;
3999 4109
4000 switch (op) 4110 switch (op)
4001 { 4111 {
4002#if USE_MATH 4112#if USE_MATH
4003 case OP_INEX2EX: /* inexact->exact */ 4113 case OP_INEX2EX: /* inexact->exact */
4004 {
4005 if (is_integer (x)) 4114 if (!is_integer (x))
4006 s_return (x); 4115 {
4007
4008 RVALUE r = rvalue_unchecked (x); 4116 RVALUE r = rvalue_unchecked (x);
4009 4117
4010 if (r == (RVALUE)(IVALUE)r) 4118 if (r == (RVALUE)(IVALUE)r)
4011 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4119 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4012 else 4120 else
4013 Error_1 ("inexact->exact: not integral:", x); 4121 Error_1 ("inexact->exact: not integral:", x);
4014 } 4122 }
4015 4123
4124 s_return (x);
4125
4126 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4127 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4128 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4129 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4130
4131 case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4016 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4132 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4017 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4133 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4134 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4018 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4135 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4019 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4136 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4020 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4137 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4021 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4138 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4022 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4139 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4023 4140
4024 case OP_ATAN: 4141 case OP_ATAN:
4142 s_return (mk_real (SCHEME_A_
4025 if (cdr (args) == NIL) 4143 cdr (args) == NIL
4026 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4144 ? atan (rvalue (x))
4027 else 4145 : atan2 (rvalue (x), rvalue (cadr (args)))));
4028 {
4029 pointer y = cadr (args);
4030 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4031 }
4032
4033 case OP_SQRT:
4034 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4035 4146
4036 case OP_EXPT: 4147 case OP_EXPT:
4037 { 4148 {
4038 RVALUE result; 4149 RVALUE result;
4039 int real_result = 1; 4150 int real_result = 1;
… …
4062 if (real_result) 4173 if (real_result)
4063 s_return (mk_real (SCHEME_A_ result)); 4174 s_return (mk_real (SCHEME_A_ result));
4064 else 4175 else
4065 s_return (mk_integer (SCHEME_A_ result)); 4176 s_return (mk_integer (SCHEME_A_ result));
4066 } 4177 }
4067
4068 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4069 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4070 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4071 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4072#endif 4178#endif
4073 4179
4074 case OP_ADD: /* + */ 4180 case OP_ADD: /* + */
4075 v = num_zero; 4181 v = num_zero;
4076 4182
… …
4378 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4484 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4379 4485
4380 s_return (newstr); 4486 s_return (newstr);
4381 } 4487 }
4382 4488
4383 case OP_SUBSTR: /* substring */ 4489 case OP_STRING_COPY: /* substring/string-copy */
4384 { 4490 {
4385 char *str = strvalue (x); 4491 char *str = strvalue (x);
4386 int index0 = ivalue_unchecked (cadr (args)); 4492 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4387 int index1; 4493 int index1;
4388 int len; 4494 int len;
4389 4495
4390 if (index0 > strlength (x)) 4496 if (index0 > strlength (x))
4391 Error_1 ("substring: start out of bounds:", cadr (args)); 4497 Error_1 ("string->copy: start out of bounds:", cadr (args));
4392 4498
4393 if (cddr (args) != NIL) 4499 if (cddr (args) != NIL)
4394 { 4500 {
4395 index1 = ivalue_unchecked (caddr (args)); 4501 index1 = ivalue_unchecked (caddr (args));
4396 4502
4397 if (index1 > strlength (x) || index1 < index0) 4503 if (index1 > strlength (x) || index1 < index0)
4398 Error_1 ("substring: end out of bounds:", caddr (args)); 4504 Error_1 ("string->copy: end out of bounds:", caddr (args));
4399 } 4505 }
4400 else 4506 else
4401 index1 = strlength (x); 4507 index1 = strlength (x);
4402 4508
4403 len = index1 - index0; 4509 len = index1 - index0;
4404 x = mk_empty_string (SCHEME_A_ len, ' '); 4510 x = mk_counted_string (SCHEME_A_ str + index0, len);
4405 memcpy (strvalue (x), str + index0, len);
4406 strvalue (x)[len] = 0;
4407 4511
4408 s_return (x); 4512 s_return (x);
4409 } 4513 }
4410 4514
4411 case OP_VECTOR: /* vector */ 4515 case OP_VECTOR: /* vector */
… …
4485 } 4589 }
4486 4590
4487 if (USE_ERROR_CHECKING) abort (); 4591 if (USE_ERROR_CHECKING) abort ();
4488} 4592}
4489 4593
4490static int 4594/* relational ops */
4595ecb_hot static int
4491opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4596opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4492{ 4597{
4493 pointer x = SCHEME_V->args; 4598 pointer x = SCHEME_V->args;
4494 4599
4495 for (;;) 4600 for (;;)
… …
4516 } 4621 }
4517 4622
4518 s_return (S_T); 4623 s_return (S_T);
4519} 4624}
4520 4625
4521static int 4626/* predicates */
4627ecb_hot static int
4522opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4628opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4523{ 4629{
4524 pointer args = SCHEME_V->args; 4630 pointer args = SCHEME_V->args;
4525 pointer a = car (args); 4631 pointer a = car (args);
4526 pointer d = cdr (args); 4632 pointer d = cdr (args);
… …
4573 } 4679 }
4574 4680
4575 s_retbool (r); 4681 s_retbool (r);
4576} 4682}
4577 4683
4578static int 4684/* promises, list ops, ports */
4685ecb_hot static int
4579opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4686opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4580{ 4687{
4581 pointer args = SCHEME_V->args; 4688 pointer args = SCHEME_V->args;
4582 pointer a = car (args); 4689 pointer a = car (args);
4583 pointer x, y; 4690 pointer x, y;
… …
4600 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4707 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4601 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); 4708 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4602 s_return (SCHEME_V->value); 4709 s_return (SCHEME_V->value);
4603 4710
4604#if USE_PORTS 4711#if USE_PORTS
4712
4713 case OP_EOF_OBJECT: /* eof-object */
4714 s_return (S_EOF);
4605 4715
4606 case OP_WRITE: /* write */ 4716 case OP_WRITE: /* write */
4607 case OP_DISPLAY: /* display */ 4717 case OP_DISPLAY: /* display */
4608 case OP_WRITE_CHAR: /* write-char */ 4718 case OP_WRITE_CHAR: /* write-char */
4609 if (is_pair (cdr (SCHEME_V->args))) 4719 if (is_pair (cdr (SCHEME_V->args)))
… …
4623 else 4733 else
4624 SCHEME_V->print_flag = 0; 4734 SCHEME_V->print_flag = 0;
4625 4735
4626 s_goto (OP_P0LIST); 4736 s_goto (OP_P0LIST);
4627 4737
4738 //TODO: move to scheme
4628 case OP_NEWLINE: /* newline */ 4739 case OP_NEWLINE: /* newline */
4629 if (is_pair (args)) 4740 if (is_pair (args))
4630 { 4741 {
4631 if (a != SCHEME_V->outport) 4742 if (a != SCHEME_V->outport)
4632 { 4743 {
… …
4634 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4745 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4635 SCHEME_V->outport = a; 4746 SCHEME_V->outport = a;
4636 } 4747 }
4637 } 4748 }
4638 4749
4639 putstr (SCHEME_A_ "\n"); 4750 putcharacter (SCHEME_A_ '\n');
4640 s_return (S_T); 4751 s_return (S_T);
4641#endif 4752#endif
4642 4753
4643 case OP_ERR0: /* error */ 4754 case OP_ERR0: /* error */
4644 SCHEME_V->retcode = -1; 4755 SCHEME_V->retcode = -1;
… …
4653 putstr (SCHEME_A_ strvalue (car (args))); 4764 putstr (SCHEME_A_ strvalue (car (args)));
4654 SCHEME_V->args = cdr (args); 4765 SCHEME_V->args = cdr (args);
4655 s_goto (OP_ERR1); 4766 s_goto (OP_ERR1);
4656 4767
4657 case OP_ERR1: /* error */ 4768 case OP_ERR1: /* error */
4658 putstr (SCHEME_A_ " "); 4769 putcharacter (SCHEME_A_ ' ');
4659 4770
4660 if (args != NIL) 4771 if (args != NIL)
4661 { 4772 {
4662 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); 4773 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4663 SCHEME_V->args = a; 4774 SCHEME_V->args = a;
4664 SCHEME_V->print_flag = 1; 4775 SCHEME_V->print_flag = 1;
4665 s_goto (OP_P0LIST); 4776 s_goto (OP_P0LIST);
4666 } 4777 }
4667 else 4778 else
4668 { 4779 {
4669 putstr (SCHEME_A_ "\n"); 4780 putcharacter (SCHEME_A_ '\n');
4670 4781
4671 if (SCHEME_V->interactive_repl) 4782 if (SCHEME_V->interactive_repl)
4672 s_goto (OP_T0LVL); 4783 s_goto (OP_T0LVL);
4673 else 4784 else
4674 return -1; 4785 return -1;
… …
4882 } 4993 }
4883 4994
4884 if (USE_ERROR_CHECKING) abort (); 4995 if (USE_ERROR_CHECKING) abort ();
4885} 4996}
4886 4997
4887static int 4998/* reading */
4999ecb_cold static int
4888opexe_5 (SCHEME_P_ enum scheme_opcodes op) 5000opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4889{ 5001{
4890 pointer args = SCHEME_V->args; 5002 pointer args = SCHEME_V->args;
4891 pointer x; 5003 pointer x;
4892 5004
… …
5161 pointer b = cdr (args); 5273 pointer b = cdr (args);
5162 int ok_abbr = ok_abbrev (b); 5274 int ok_abbr = ok_abbrev (b);
5163 SCHEME_V->args = car (b); 5275 SCHEME_V->args = car (b);
5164 5276
5165 if (a == SCHEME_V->QUOTE && ok_abbr) 5277 if (a == SCHEME_V->QUOTE && ok_abbr)
5166 putstr (SCHEME_A_ "'"); 5278 putcharacter (SCHEME_A_ '\'');
5167 else if (a == SCHEME_V->QQUOTE && ok_abbr) 5279 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5168 putstr (SCHEME_A_ "`"); 5280 putcharacter (SCHEME_A_ '`');
5169 else if (a == SCHEME_V->UNQUOTE && ok_abbr) 5281 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5170 putstr (SCHEME_A_ ","); 5282 putcharacter (SCHEME_A_ ',');
5171 else if (a == SCHEME_V->UNQUOTESP && ok_abbr) 5283 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5172 putstr (SCHEME_A_ ",@"); 5284 putstr (SCHEME_A_ ",@");
5173 else 5285 else
5174 { 5286 {
5175 putstr (SCHEME_A_ "("); 5287 putcharacter (SCHEME_A_ '(');
5176 s_save (SCHEME_A_ OP_P1LIST, b, NIL); 5288 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5177 SCHEME_V->args = a; 5289 SCHEME_V->args = a;
5178 } 5290 }
5179 5291
5180 s_goto (OP_P0LIST); 5292 s_goto (OP_P0LIST);
… …
5182 5294
5183 case OP_P1LIST: 5295 case OP_P1LIST:
5184 if (is_pair (args)) 5296 if (is_pair (args))
5185 { 5297 {
5186 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); 5298 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5187 putstr (SCHEME_A_ " "); 5299 putcharacter (SCHEME_A_ ' ');
5188 SCHEME_V->args = car (args); 5300 SCHEME_V->args = car (args);
5189 s_goto (OP_P0LIST); 5301 s_goto (OP_P0LIST);
5190 } 5302 }
5191 else if (is_vector (args)) 5303 else if (is_vector (args))
5192 { 5304 {
… …
5200 { 5312 {
5201 putstr (SCHEME_A_ " . "); 5313 putstr (SCHEME_A_ " . ");
5202 printatom (SCHEME_A_ args, SCHEME_V->print_flag); 5314 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5203 } 5315 }
5204 5316
5205 putstr (SCHEME_A_ ")"); 5317 putcharacter (SCHEME_A_ ')');
5206 s_return (S_T); 5318 s_return (S_T);
5207 } 5319 }
5208 5320
5209 case OP_PVECFROM: 5321 case OP_PVECFROM:
5210 { 5322 {
… …
5212 pointer vec = car (args); 5324 pointer vec = car (args);
5213 int len = veclength (vec); 5325 int len = veclength (vec);
5214 5326
5215 if (i == len) 5327 if (i == len)
5216 { 5328 {
5217 putstr (SCHEME_A_ ")"); 5329 putcharacter (SCHEME_A_ ')');
5218 s_return (S_T); 5330 s_return (S_T);
5219 } 5331 }
5220 else 5332 else
5221 { 5333 {
5222 pointer elem = vector_get (vec, i); 5334 pointer elem = vector_get (vec, i);
… …
5224 ivalue_unchecked (cdr (args)) = i + 1; 5336 ivalue_unchecked (cdr (args)) = i + 1;
5225 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5337 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5226 SCHEME_V->args = elem; 5338 SCHEME_V->args = elem;
5227 5339
5228 if (i > 0) 5340 if (i > 0)
5229 putstr (SCHEME_A_ " "); 5341 putcharacter (SCHEME_A_ ' ');
5230 5342
5231 s_goto (OP_P0LIST); 5343 s_goto (OP_P0LIST);
5232 } 5344 }
5233 } 5345 }
5234 } 5346 }
5235 5347
5236 if (USE_ERROR_CHECKING) abort (); 5348 if (USE_ERROR_CHECKING) abort ();
5237} 5349}
5238 5350
5239static int 5351/* list ops */
5352ecb_hot static int
5240opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5353opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5241{ 5354{
5242 pointer args = SCHEME_V->args; 5355 pointer args = SCHEME_V->args;
5243 pointer a = car (args); 5356 pointer a = car (args);
5244 pointer x, y; 5357 pointer x, y;
… …
5302 5415
5303/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5416/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5304typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); 5417typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5305 5418
5306typedef int (*test_predicate)(pointer); 5419typedef int (*test_predicate)(pointer);
5307static int 5420
5421ecb_hot static int
5308tst_any (pointer p) 5422tst_any (pointer p)
5309{ 5423{
5310 return 1; 5424 return 1;
5311} 5425}
5312 5426
5313static int 5427ecb_hot static int
5314tst_inonneg (pointer p) 5428tst_inonneg (pointer p)
5315{ 5429{
5316 return is_integer (p) && ivalue_unchecked (p) >= 0; 5430 return is_integer (p) && ivalue_unchecked (p) >= 0;
5317} 5431}
5318 5432
5319static int 5433ecb_hot static int
5320tst_is_list (SCHEME_P_ pointer p) 5434tst_is_list (SCHEME_P_ pointer p)
5321{ 5435{
5322 return p == NIL || is_pair (p); 5436 return p == NIL || is_pair (p);
5323} 5437}
5324 5438
… …
5367#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" 5481#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5368#include "opdefines.h" 5482#include "opdefines.h"
5369#undef OP_DEF 5483#undef OP_DEF
5370; 5484;
5371 5485
5372static const char * 5486ecb_cold static const char *
5373opname (int idx) 5487opname (int idx)
5374{ 5488{
5375 const char *name = opnames; 5489 const char *name = opnames;
5376 5490
5377 /* should do this at compile time, but would require external program, right? */ 5491 /* should do this at compile time, but would require external program, right? */
… …
5379 name += strlen (name) + 1; 5493 name += strlen (name) + 1;
5380 5494
5381 return *name ? name : "ILLEGAL"; 5495 return *name ? name : "ILLEGAL";
5382} 5496}
5383 5497
5384static const char * 5498ecb_cold static const char *
5385procname (pointer x) 5499procname (pointer x)
5386{ 5500{
5387 return opname (procnum (x)); 5501 return opname (procnum (x));
5388} 5502}
5389 5503
… …
5409#undef OP_DEF 5523#undef OP_DEF
5410 {0} 5524 {0}
5411}; 5525};
5412 5526
5413/* kernel of this interpreter */ 5527/* kernel of this interpreter */
5414static void ecb_hot 5528ecb_hot static void
5415Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5529Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5416{ 5530{
5417 SCHEME_V->op = op; 5531 SCHEME_V->op = op;
5418 5532
5419 for (;;) 5533 for (;;)
… …
5510 } 5624 }
5511} 5625}
5512 5626
5513/* ========== Initialization of internal keywords ========== */ 5627/* ========== Initialization of internal keywords ========== */
5514 5628
5515static void 5629ecb_cold static void
5516assign_syntax (SCHEME_P_ const char *name) 5630assign_syntax (SCHEME_P_ const char *name)
5517{ 5631{
5518 pointer x = oblist_add_by_name (SCHEME_A_ name); 5632 pointer x = oblist_add_by_name (SCHEME_A_ name);
5519 set_typeflag (x, typeflag (x) | T_SYNTAX); 5633 set_typeflag (x, typeflag (x) | T_SYNTAX);
5520} 5634}
5521 5635
5522static void 5636ecb_cold static void
5523assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5637assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5524{ 5638{
5525 pointer x = mk_symbol (SCHEME_A_ name); 5639 pointer x = mk_symbol (SCHEME_A_ name);
5526 pointer y = mk_proc (SCHEME_A_ op); 5640 pointer y = mk_proc (SCHEME_A_ op);
5527 new_slot_in_env (SCHEME_A_ x, y); 5641 new_slot_in_env (SCHEME_A_ x, y);
… …
5535 ivalue_unchecked (y) = op; 5649 ivalue_unchecked (y) = op;
5536 return y; 5650 return y;
5537} 5651}
5538 5652
5539/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5653/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5540static int 5654ecb_hot static int
5541syntaxnum (pointer p) 5655syntaxnum (pointer p)
5542{ 5656{
5543 const char *s = strvalue (p); 5657 const char *s = strvalue (p);
5544 5658
5545 switch (strlength (p)) 5659 switch (strlength (p))
… …
5662#endif 5776#endif
5663 } 5777 }
5664 5778
5665 SCHEME_V->gc_verbose = 0; 5779 SCHEME_V->gc_verbose = 0;
5666 dump_stack_initialize (SCHEME_A); 5780 dump_stack_initialize (SCHEME_A);
5667 SCHEME_V->code = NIL; 5781 SCHEME_V->code = NIL;
5668 SCHEME_V->args = NIL; 5782 SCHEME_V->args = NIL;
5669 SCHEME_V->envir = NIL; 5783 SCHEME_V->envir = NIL;
5784 SCHEME_V->value = NIL;
5670 SCHEME_V->tracing = 0; 5785 SCHEME_V->tracing = 0;
5671 5786
5672 /* init NIL */ 5787 /* init NIL */
5673 set_typeflag (NIL, T_ATOM | T_MARK); 5788 set_typeflag (NIL, T_ATOM | T_MARK);
5674 set_car (NIL, NIL); 5789 set_car (NIL, NIL);
… …
5730 5845
5731 return !SCHEME_V->no_memory; 5846 return !SCHEME_V->no_memory;
5732} 5847}
5733 5848
5734#if USE_PORTS 5849#if USE_PORTS
5735void 5850ecb_cold void
5736scheme_set_input_port_file (SCHEME_P_ int fin) 5851scheme_set_input_port_file (SCHEME_P_ int fin)
5737{ 5852{
5738 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 5853 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5739} 5854}
5740 5855
5741void 5856ecb_cold void
5742scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 5857scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5743{ 5858{
5744 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 5859 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5745} 5860}
5746 5861
5747void 5862ecb_cold void
5748scheme_set_output_port_file (SCHEME_P_ int fout) 5863scheme_set_output_port_file (SCHEME_P_ int fout)
5749{ 5864{
5750 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 5865 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5751} 5866}
5752 5867
5753void 5868ecb_cold void
5754scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 5869scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5755{ 5870{
5756 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 5871 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5757} 5872}
5758#endif 5873#endif
5759 5874
5760void 5875ecb_cold void
5761scheme_set_external_data (SCHEME_P_ void *p) 5876scheme_set_external_data (SCHEME_P_ void *p)
5762{ 5877{
5763 SCHEME_V->ext_data = p; 5878 SCHEME_V->ext_data = p;
5764} 5879}
5765 5880
… …
5813 } 5928 }
5814 } 5929 }
5815#endif 5930#endif
5816} 5931}
5817 5932
5818void 5933ecb_cold void
5819scheme_load_file (SCHEME_P_ int fin) 5934scheme_load_file (SCHEME_P_ int fin)
5820{ 5935{
5821 scheme_load_named_file (SCHEME_A_ fin, 0); 5936 scheme_load_named_file (SCHEME_A_ fin, 0);
5822} 5937}
5823 5938
5824void 5939ecb_cold void
5825scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 5940scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5826{ 5941{
5827 dump_stack_reset (SCHEME_A); 5942 dump_stack_reset (SCHEME_A);
5828 SCHEME_V->envir = SCHEME_V->global_env; 5943 SCHEME_V->envir = SCHEME_V->global_env;
5829 SCHEME_V->file_i = 0; 5944 SCHEME_V->file_i = 0;
5830 SCHEME_V->load_stack[0].unget = -1; 5945 SCHEME_V->load_stack[0].unget = -1;
5831 SCHEME_V->load_stack[0].kind = port_input | port_file; 5946 SCHEME_V->load_stack[0].kind = port_input | port_file;
5832 SCHEME_V->load_stack[0].rep.stdio.file = fin; 5947 SCHEME_V->load_stack[0].rep.stdio.file = fin;
5833#if USE_PORTS
5834 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 5948 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5835#endif
5836 SCHEME_V->retcode = 0; 5949 SCHEME_V->retcode = 0;
5837 5950
5838#if USE_PORTS
5839 if (fin == STDIN_FILENO) 5951 if (fin == STDIN_FILENO)
5840 SCHEME_V->interactive_repl = 1; 5952 SCHEME_V->interactive_repl = 1;
5841#endif
5842 5953
5843#if USE_PORTS 5954#if USE_PORTS
5844#if SHOW_ERROR_LINE 5955#if SHOW_ERROR_LINE
5845 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0; 5956 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5846 5957
… …
5850#endif 5961#endif
5851 5962
5852 SCHEME_V->inport = SCHEME_V->loadport; 5963 SCHEME_V->inport = SCHEME_V->loadport;
5853 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 5964 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5854 Eval_Cycle (SCHEME_A_ OP_T0LVL); 5965 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5966
5855 set_typeflag (SCHEME_V->loadport, T_ATOM); 5967 set_typeflag (SCHEME_V->loadport, T_ATOM);
5856 5968
5857 if (SCHEME_V->retcode == 0) 5969 if (SCHEME_V->retcode == 0)
5858 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5970 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5859} 5971}
5860 5972
5861void 5973ecb_cold void
5862scheme_load_string (SCHEME_P_ const char *cmd) 5974scheme_load_string (SCHEME_P_ const char *cmd)
5863{ 5975{
5976#if USE_PORTs
5864 dump_stack_reset (SCHEME_A); 5977 dump_stack_reset (SCHEME_A);
5865 SCHEME_V->envir = SCHEME_V->global_env; 5978 SCHEME_V->envir = SCHEME_V->global_env;
5866 SCHEME_V->file_i = 0; 5979 SCHEME_V->file_i = 0;
5867 SCHEME_V->load_stack[0].kind = port_input | port_string; 5980 SCHEME_V->load_stack[0].kind = port_input | port_string;
5868 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ 5981 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5869 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); 5982 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5870 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; 5983 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5871#if USE_PORTS
5872 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 5984 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5873#endif
5874 SCHEME_V->retcode = 0; 5985 SCHEME_V->retcode = 0;
5875 SCHEME_V->interactive_repl = 0; 5986 SCHEME_V->interactive_repl = 0;
5876 SCHEME_V->inport = SCHEME_V->loadport; 5987 SCHEME_V->inport = SCHEME_V->loadport;
5877 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 5988 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5878 Eval_Cycle (SCHEME_A_ OP_T0LVL); 5989 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5879 set_typeflag (SCHEME_V->loadport, T_ATOM); 5990 set_typeflag (SCHEME_V->loadport, T_ATOM);
5880 5991
5881 if (SCHEME_V->retcode == 0) 5992 if (SCHEME_V->retcode == 0)
5882 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5993 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5994#else
5995 abort ();
5996#endif
5883} 5997}
5884 5998
5885void 5999ecb_cold void
5886scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 6000scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5887{ 6001{
5888 pointer x; 6002 pointer x;
5889 6003
5890 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 6004 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5895 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 6009 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5896} 6010}
5897 6011
5898#if !STANDALONE 6012#if !STANDALONE
5899 6013
5900void 6014ecb_cold void
5901scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 6015scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5902{ 6016{
5903 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 6017 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5904} 6018}
5905 6019
5906void 6020ecb_cold void
5907scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 6021scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5908{ 6022{
5909 int i; 6023 int i;
5910 6024
5911 for (i = 0; i < count; i++) 6025 for (i = 0; i < count; i++)
5912 scheme_register_foreign_func (SCHEME_A_ list + i); 6026 scheme_register_foreign_func (SCHEME_A_ list + i);
5913} 6027}
5914 6028
5915pointer 6029ecb_cold pointer
5916scheme_apply0 (SCHEME_P_ const char *procname) 6030scheme_apply0 (SCHEME_P_ const char *procname)
5917{ 6031{
5918 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 6032 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5919} 6033}
5920 6034
5921void 6035ecb_cold void
5922save_from_C_call (SCHEME_P) 6036save_from_C_call (SCHEME_P)
5923{ 6037{
5924 pointer saved_data = cons (car (S_SINK), 6038 pointer saved_data = cons (car (S_SINK),
5925 cons (SCHEME_V->envir, 6039 cons (SCHEME_V->envir,
5926 SCHEME_V->dump)); 6040 SCHEME_V->dump));
… …
5930 /* Truncate the dump stack so TS will return here when done, not 6044 /* Truncate the dump stack so TS will return here when done, not
5931 directly resume pre-C-call operations. */ 6045 directly resume pre-C-call operations. */
5932 dump_stack_reset (SCHEME_A); 6046 dump_stack_reset (SCHEME_A);
5933} 6047}
5934 6048
5935void 6049ecb_cold void
5936restore_from_C_call (SCHEME_P) 6050restore_from_C_call (SCHEME_P)
5937{ 6051{
5938 set_car (S_SINK, caar (SCHEME_V->c_nest)); 6052 set_car (S_SINK, caar (SCHEME_V->c_nest));
5939 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 6053 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5940 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 6054 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5941 /* Pop */ 6055 /* Pop */
5942 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 6056 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5943} 6057}
5944 6058
5945/* "func" and "args" are assumed to be already eval'ed. */ 6059/* "func" and "args" are assumed to be already eval'ed. */
5946pointer 6060ecb_cold pointer
5947scheme_call (SCHEME_P_ pointer func, pointer args) 6061scheme_call (SCHEME_P_ pointer func, pointer args)
5948{ 6062{
5949 int old_repl = SCHEME_V->interactive_repl; 6063 int old_repl = SCHEME_V->interactive_repl;
5950 6064
5951 SCHEME_V->interactive_repl = 0; 6065 SCHEME_V->interactive_repl = 0;
… …
5958 SCHEME_V->interactive_repl = old_repl; 6072 SCHEME_V->interactive_repl = old_repl;
5959 restore_from_C_call (SCHEME_A); 6073 restore_from_C_call (SCHEME_A);
5960 return SCHEME_V->value; 6074 return SCHEME_V->value;
5961} 6075}
5962 6076
5963pointer 6077ecb_cold pointer
5964scheme_eval (SCHEME_P_ pointer obj) 6078scheme_eval (SCHEME_P_ pointer obj)
5965{ 6079{
5966 int old_repl = SCHEME_V->interactive_repl; 6080 int old_repl = SCHEME_V->interactive_repl;
5967 6081
5968 SCHEME_V->interactive_repl = 0; 6082 SCHEME_V->interactive_repl = 0;
… …
5980 6094
5981/* ========== Main ========== */ 6095/* ========== Main ========== */
5982 6096
5983#if STANDALONE 6097#if STANDALONE
5984 6098
5985int 6099ecb_cold int
5986main (int argc, char **argv) 6100main (int argc, char **argv)
5987{ 6101{
5988# if USE_MULTIPLICITY 6102# if USE_MULTIPLICITY
5989 scheme ssc; 6103 scheme ssc;
5990 scheme *const SCHEME_V = &ssc; 6104 scheme *const SCHEME_V = &ssc;
… …
6031 } 6145 }
6032#endif 6146#endif
6033 6147
6034 do 6148 do
6035 { 6149 {
6036#if USE_PORTS
6037 if (strcmp (file_name, "-") == 0) 6150 if (strcmp (file_name, "-") == 0)
6038 fin = STDIN_FILENO; 6151 fin = STDIN_FILENO;
6039 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) 6152 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
6040 { 6153 {
6041 pointer args = NIL; 6154 pointer args = NIL;
… …
6059 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args); 6172 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
6060 6173
6061 } 6174 }
6062 else 6175 else
6063 fin = open (file_name, O_RDONLY); 6176 fin = open (file_name, O_RDONLY);
6064#endif
6065 6177
6066 if (isfile && fin < 0) 6178 if (isfile && fin < 0)
6067 { 6179 {
6068 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); 6180 putstr (SCHEME_A_ "Could not open file ");
6181 putstr (SCHEME_A_ file_name);
6182 putcharacter (SCHEME_A_ '\n');
6069 } 6183 }
6070 else 6184 else
6071 { 6185 {
6072 if (isfile) 6186 if (isfile)
6073 scheme_load_named_file (SCHEME_A_ fin, file_name); 6187 scheme_load_named_file (SCHEME_A_ fin, file_name);
6074 else 6188 else
6075 scheme_load_string (SCHEME_A_ file_name); 6189 scheme_load_string (SCHEME_A_ file_name);
6076 6190
6077#if USE_PORTS
6078 if (!isfile || fin != STDIN_FILENO) 6191 if (!isfile || fin != STDIN_FILENO)
6079 { 6192 {
6080 if (SCHEME_V->retcode != 0) 6193 if (SCHEME_V->retcode != 0)
6081 { 6194 {
6082 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); 6195 putstr (SCHEME_A_ "Errors encountered reading ");
6196 putstr (SCHEME_A_ file_name);
6197 putcharacter (SCHEME_A_ '\n');
6083 } 6198 }
6084 6199
6085 if (isfile) 6200 if (isfile)
6086 close (fin); 6201 close (fin);
6087 } 6202 }
6088#endif
6089 } 6203 }
6090 6204
6091 file_name = *argv++; 6205 file_name = *argv++;
6092 } 6206 }
6093 while (file_name != 0); 6207 while (file_name != 0);

Diff Legend

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