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.55 by root, Tue Dec 1 03:03:11 2015 UTC vs.
Revision 1.62 by root, Wed Dec 2 07:59:15 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);
696static char *readstr_upto (SCHEME_P_ int skip, const char *delim); 710static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
697static pointer readstrexp (SCHEME_P_ char delim); 711static pointer readstrexp (SCHEME_P_ char delim);
698ecb_inline int skipspace (SCHEME_P); 712static int skipspace (SCHEME_P);
699static int token (SCHEME_P); 713static int token (SCHEME_P);
700static void printslashstring (SCHEME_P_ char *s, int len); 714static void printslashstring (SCHEME_P_ char *s, int len);
701static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 715static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
702static void printatom (SCHEME_P_ pointer l, int f); 716static void printatom (SCHEME_P_ pointer l, int f);
703static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 717static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
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;
… …
902 916
903 if (!cp && USE_ERROR_CHECKING) 917 if (!cp && USE_ERROR_CHECKING)
904 return k; 918 return k;
905 919
906 i = ++SCHEME_V->last_cell_seg; 920 i = ++SCHEME_V->last_cell_seg;
907 SCHEME_V->alloc_seg[i] = cp;
908 921
909 newp = (struct cell *)cp; 922 newp = (struct cell *)cp;
910 SCHEME_V->cell_seg[i] = newp; 923 SCHEME_V->cell_seg[i] = newp;
911 SCHEME_V->cell_segsize[i] = segsize; 924 SCHEME_V->cell_segsize[i] = segsize;
912 SCHEME_V->fcells += segsize; 925 SCHEME_V->fcells += segsize;
… …
935 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 948 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
936 return S_SINK; 949 return S_SINK;
937 950
938 if (SCHEME_V->free_cell == NIL) 951 if (SCHEME_V->free_cell == NIL)
939 { 952 {
940 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1; 953 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
941 954
942 gc (SCHEME_A_ a, b); 955 gc (SCHEME_A_ a, b);
943 956
944 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 957 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
945 { 958 {
… …
964 } 977 }
965} 978}
966 979
967/* To retain recent allocs before interpreter knows about them - 980/* To retain recent allocs before interpreter knows about them -
968 Tehom */ 981 Tehom */
969static void 982ecb_hot static void
970push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 983push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
971{ 984{
972 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 985 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
973 986
974 set_typeflag (holder, T_PAIR); 987 set_typeflag (holder, T_PAIR);
… …
976 set_car (holder, recent); 989 set_car (holder, recent);
977 set_cdr (holder, car (S_SINK)); 990 set_cdr (holder, car (S_SINK));
978 set_car (S_SINK, holder); 991 set_car (S_SINK, holder);
979} 992}
980 993
981static pointer 994ecb_hot static pointer
982get_cell (SCHEME_P_ pointer a, pointer b) 995get_cell (SCHEME_P_ pointer a, pointer b)
983{ 996{
984 pointer cell = get_cell_x (SCHEME_A_ a, b); 997 pointer cell = get_cell_x (SCHEME_A_ a, b);
985 998
986 /* For right now, include "a" and "b" in "cell" so that gc doesn't 999 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1043#endif 1056#endif
1044 1057
1045/* Medium level cell allocation */ 1058/* Medium level cell allocation */
1046 1059
1047/* get new cons cell */ 1060/* get new cons cell */
1048pointer 1061ecb_hot static pointer
1049xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1062xcons (SCHEME_P_ pointer a, pointer b)
1050{ 1063{
1051 pointer x = get_cell (SCHEME_A_ a, b); 1064 pointer x = get_cell (SCHEME_A_ a, b);
1052 1065
1053 set_typeflag (x, T_PAIR); 1066 set_typeflag (x, T_PAIR);
1054
1055 if (immutable)
1056 setimmutable (x);
1057 1067
1058 set_car (x, a); 1068 set_car (x, a);
1059 set_cdr (x, b); 1069 set_cdr (x, b);
1060 1070
1061 return x; 1071 return x;
1062} 1072}
1063 1073
1064static pointer 1074ecb_hot static pointer
1075ximmutable_cons (SCHEME_P_ pointer a, pointer b)
1076{
1077 pointer x = xcons (SCHEME_A_ a, b);
1078 setimmutable (x);
1079 return x;
1080}
1081
1082#define cons(a,b) xcons (SCHEME_A_ a, b)
1083#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1084
1085ecb_cold static pointer
1065generate_symbol (SCHEME_P_ const char *name) 1086generate_symbol (SCHEME_P_ const char *name)
1066{ 1087{
1067 pointer x = mk_string (SCHEME_A_ name); 1088 pointer x = mk_string (SCHEME_A_ name);
1068 setimmutable (x); 1089 setimmutable (x);
1069 set_typeflag (x, T_SYMBOL | T_ATOM); 1090 set_typeflag (x, T_SYMBOL | T_ATOM);
… …
1075#ifndef USE_OBJECT_LIST 1096#ifndef USE_OBJECT_LIST
1076 1097
1077static int 1098static int
1078hash_fn (const char *key, int table_size) 1099hash_fn (const char *key, int table_size)
1079{ 1100{
1080 const unsigned char *p = key; 1101 const unsigned char *p = (unsigned char *)key;
1081 uint32_t hash = 2166136261; 1102 uint32_t hash = 2166136261;
1082 1103
1083 while (*p) 1104 while (*p)
1084 hash = (hash ^ *p++) * 16777619; 1105 hash = (hash ^ *p++) * 16777619;
1085 1106
1086 return hash % table_size; 1107 return hash % table_size;
1087} 1108}
1088 1109
1089static pointer 1110ecb_cold static pointer
1090oblist_initial_value (SCHEME_P) 1111oblist_initial_value (SCHEME_P)
1091{ 1112{
1092 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1113 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1093} 1114}
1094 1115
1095/* returns the new symbol */ 1116/* returns the new symbol */
1096static pointer 1117ecb_cold static pointer
1097oblist_add_by_name (SCHEME_P_ const char *name) 1118oblist_add_by_name (SCHEME_P_ const char *name)
1098{ 1119{
1099 pointer x = generate_symbol (SCHEME_A_ name); 1120 pointer x = generate_symbol (SCHEME_A_ name);
1100 int location = hash_fn (name, veclength (SCHEME_V->oblist)); 1121 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))); 1122 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1102 return x; 1123 return x;
1103} 1124}
1104 1125
1105ecb_inline pointer 1126ecb_cold static pointer
1106oblist_find_by_name (SCHEME_P_ const char *name) 1127oblist_find_by_name (SCHEME_P_ const char *name)
1107{ 1128{
1108 int location; 1129 int location;
1109 pointer x; 1130 pointer x;
1110 char *s; 1131 char *s;
… …
1121 } 1142 }
1122 1143
1123 return NIL; 1144 return NIL;
1124} 1145}
1125 1146
1126static pointer 1147ecb_cold static pointer
1127oblist_all_symbols (SCHEME_P) 1148oblist_all_symbols (SCHEME_P)
1128{ 1149{
1129 int i; 1150 int i;
1130 pointer x; 1151 pointer x;
1131 pointer ob_list = NIL; 1152 pointer ob_list = NIL;
… …
1137 return ob_list; 1158 return ob_list;
1138} 1159}
1139 1160
1140#else 1161#else
1141 1162
1142static pointer 1163ecb_cold static pointer
1143oblist_initial_value (SCHEME_P) 1164oblist_initial_value (SCHEME_P)
1144{ 1165{
1145 return NIL; 1166 return NIL;
1146} 1167}
1147 1168
1148ecb_inline pointer 1169ecb_cold static pointer
1149oblist_find_by_name (SCHEME_P_ const char *name) 1170oblist_find_by_name (SCHEME_P_ const char *name)
1150{ 1171{
1151 pointer x; 1172 pointer x;
1152 char *s; 1173 char *s;
1153 1174
… …
1162 1183
1163 return NIL; 1184 return NIL;
1164} 1185}
1165 1186
1166/* returns the new symbol */ 1187/* returns the new symbol */
1167static pointer 1188ecb_cold static pointer
1168oblist_add_by_name (SCHEME_P_ const char *name) 1189oblist_add_by_name (SCHEME_P_ const char *name)
1169{ 1190{
1170 pointer x = generate_symbol (SCHEME_A_ name); 1191 pointer x = generate_symbol (SCHEME_A_ name);
1171 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1192 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1172 return x; 1193 return x;
1173} 1194}
1174 1195
1175static pointer 1196ecb_cold static pointer
1176oblist_all_symbols (SCHEME_P) 1197oblist_all_symbols (SCHEME_P)
1177{ 1198{
1178 return SCHEME_V->oblist; 1199 return SCHEME_V->oblist;
1179} 1200}
1180 1201
1181#endif 1202#endif
1182 1203
1183#if USE_PORTS
1184static pointer 1204ecb_cold static pointer
1185mk_port (SCHEME_P_ port *p) 1205mk_port (SCHEME_P_ port *p)
1186{ 1206{
1187 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1207 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1188 1208
1189 set_typeflag (x, T_PORT | T_ATOM); 1209 set_typeflag (x, T_PORT | T_ATOM);
1190 set_port (x, p); 1210 set_port (x, p);
1191 1211
1192 return x; 1212 return x;
1193} 1213}
1194#endif
1195 1214
1196pointer 1215ecb_cold pointer
1197mk_foreign_func (SCHEME_P_ foreign_func f) 1216mk_foreign_func (SCHEME_P_ foreign_func f)
1198{ 1217{
1199 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1218 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1200 1219
1201 set_typeflag (x, T_FOREIGN | T_ATOM); 1220 set_typeflag (x, T_FOREIGN | T_ATOM);
… …
1366 x = oblist_add_by_name (SCHEME_A_ name); 1385 x = oblist_add_by_name (SCHEME_A_ name);
1367 1386
1368 return x; 1387 return x;
1369} 1388}
1370 1389
1371INTERFACE pointer 1390ecb_cold INTERFACE pointer
1372gensym (SCHEME_P) 1391gensym (SCHEME_P)
1373{ 1392{
1374 pointer x; 1393 pointer x;
1375 char name[40] = "gensym-"; 1394 char name[40] = "gensym-";
1376 xnum (name + 7, ++SCHEME_V->gensym_cnt); 1395 xnum (name + 7, ++SCHEME_V->gensym_cnt);
… …
1383{ 1402{
1384 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; 1403 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1385} 1404}
1386 1405
1387/* make symbol or number atom from string */ 1406/* make symbol or number atom from string */
1388static pointer 1407ecb_cold static pointer
1389mk_atom (SCHEME_P_ char *q) 1408mk_atom (SCHEME_P_ char *q)
1390{ 1409{
1391 char c, *p; 1410 char c, *p;
1392 int has_dec_point = 0; 1411 int has_dec_point = 0;
1393 int has_fp_exp = 0; 1412 int has_fp_exp = 0;
… …
1464 1483
1465 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1484 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1466} 1485}
1467 1486
1468/* make constant */ 1487/* make constant */
1469static pointer 1488ecb_cold static pointer
1470mk_sharp_const (SCHEME_P_ char *name) 1489mk_sharp_const (SCHEME_P_ char *name)
1471{ 1490{
1472 if (!strcmp (name, "t")) 1491 if (!strcmp (name, "t"))
1473 return S_T; 1492 return S_T;
1474 else if (!strcmp (name, "f")) 1493 else if (!strcmp (name, "f"))
1475 return S_F; 1494 return S_F;
1476 else if (*name == '\\') /* #\w (character) */ 1495 else if (*name == '\\') /* #\w (character) */
1477 { 1496 {
1478 int c; 1497 int c;
1479 1498
1499 // TODO: optimise
1480 if (stricmp (name + 1, "space") == 0) 1500 if (stricmp (name + 1, "space") == 0)
1481 c = ' '; 1501 c = ' ';
1482 else if (stricmp (name + 1, "newline") == 0) 1502 else if (stricmp (name + 1, "newline") == 0)
1483 c = '\n'; 1503 c = '\n';
1484 else if (stricmp (name + 1, "return") == 0) 1504 else if (stricmp (name + 1, "return") == 0)
1485 c = '\r'; 1505 c = '\r';
1486 else if (stricmp (name + 1, "tab") == 0) 1506 else if (stricmp (name + 1, "tab") == 0)
1487 c = '\t'; 1507 c = '\t';
1508 else if (stricmp (name + 1, "alarm") == 0)
1509 c = 0x07;
1510 else if (stricmp (name + 1, "backspace") == 0)
1511 c = 0x08;
1512 else if (stricmp (name + 1, "escape") == 0)
1513 c = 0x1b;
1514 else if (stricmp (name + 1, "delete") == 0)
1515 c = 0x7f;
1516 else if (stricmp (name + 1, "null") == 0)
1517 c = 0;
1488 else if (name[1] == 'x' && name[2] != 0) 1518 else if (name[1] == 'x' && name[2] != 0)
1489 { 1519 {
1490 long c1 = strtol (name + 2, 0, 16); 1520 long c1 = strtol (name + 2, 0, 16);
1491 1521
1492 if (0 <= c1 && c1 <= UCHAR_MAX) 1522 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1517 return NIL; 1547 return NIL;
1518 } 1548 }
1519} 1549}
1520 1550
1521/* ========== garbage collector ========== */ 1551/* ========== garbage collector ========== */
1552
1553static void
1554finalize_cell (SCHEME_P_ pointer a)
1555{
1556 /* TODO, fast bitmap check? */
1557 if (is_string (a) || is_symbol (a))
1558 free (strvalue (a));
1559 else if (is_vector (a))
1560 free (vecvalue (a));
1561#if USE_PORTS
1562 else if (is_port (a))
1563 {
1564 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1565 port_close (SCHEME_A_ a, port_input | port_output);
1566
1567 free (port (a));
1568 }
1569#endif
1570}
1522 1571
1523/*-- 1572/*--
1524 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1573 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1525 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1574 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1526 * for marking. 1575 * for marking.
1527 * 1576 *
1528 * The exception is vectors - vectors are currently marked recursively, 1577 * The exception is vectors - vectors are currently marked recursively,
1529 * which is inherited form tinyscheme and could be fixed by having another 1578 * which is inherited form tinyscheme and could be fixed by having another
1530 * word of context in the vector 1579 * word of context in the vector
1531 */ 1580 */
1532static void 1581ecb_hot static void
1533mark (pointer a) 1582mark (pointer a)
1534{ 1583{
1535 pointer t, q, p; 1584 pointer t, q, p;
1536 1585
1537 t = 0; 1586 t = 0;
… …
1594 p = q; 1643 p = q;
1595 goto E6; 1644 goto E6;
1596 } 1645 }
1597} 1646}
1598 1647
1599/* garbage collection. parameter a, b is marked. */ 1648ecb_hot static void
1600static void 1649gc_free (SCHEME_P)
1601gc (SCHEME_P_ pointer a, pointer b)
1602{ 1650{
1603 int i; 1651 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; 1652 uint32_t total = 0;
1648 1653
1649 /* Here we scan the cells to build the free-list. */ 1654 /* Here we scan the cells to build the free-list. */
1650 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1655 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1651 { 1656 {
… …
1680 { 1685 {
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"); 1686 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 } 1687 }
1683} 1688}
1684 1689
1685static void 1690/* garbage collection. parameter a, b is marked. */
1686finalize_cell (SCHEME_P_ pointer a) 1691ecb_cold static void
1692gc (SCHEME_P_ pointer a, pointer b)
1687{ 1693{
1688 /* TODO, fast bitmap check? */ 1694 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 1695
1699 free (port (a)); 1696 if (SCHEME_V->gc_verbose)
1700 } 1697 putstr (SCHEME_A_ "gc...");
1698
1699 /* mark system globals */
1700 mark (SCHEME_V->oblist);
1701 mark (SCHEME_V->global_env);
1702
1703 /* mark current registers */
1704 mark (SCHEME_V->args);
1705 mark (SCHEME_V->envir);
1706 mark (SCHEME_V->code);
1707 dump_stack_mark (SCHEME_A);
1708 mark (SCHEME_V->value);
1709 mark (SCHEME_V->inport);
1710 mark (SCHEME_V->save_inport);
1711 mark (SCHEME_V->outport);
1712 mark (SCHEME_V->loadport);
1713
1714 /* Mark recent objects the interpreter doesn't know about yet. */
1715 mark (car (S_SINK));
1716 /* Mark any older stuff above nested C calls */
1717 mark (SCHEME_V->c_nest);
1718
1719#if USE_INTCACHE
1720 /* mark intcache */
1721 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1722 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1723 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1701#endif 1724#endif
1725
1726 /* mark variables a, b */
1727 mark (a);
1728 mark (b);
1729
1730 /* garbage collect */
1731 clrmark (NIL);
1732 SCHEME_V->fcells = 0;
1733 SCHEME_V->free_cell = NIL;
1734
1735 if (SCHEME_V->gc_verbose)
1736 putstr (SCHEME_A_ "freeing...");
1737
1738 gc_free (SCHEME_A);
1702} 1739}
1703 1740
1704/* ========== Routines for Reading ========== */ 1741/* ========== Routines for Reading ========== */
1705 1742
1706static int 1743ecb_cold static int
1707file_push (SCHEME_P_ const char *fname) 1744file_push (SCHEME_P_ const char *fname)
1708{ 1745{
1709#if USE_PORTS
1710 int fin; 1746 int fin;
1711 1747
1712 if (SCHEME_V->file_i == MAXFIL - 1) 1748 if (SCHEME_V->file_i == MAXFIL - 1)
1713 return 0; 1749 return 0;
1714 1750
… …
1731 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0); 1767 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1732#endif 1768#endif
1733 } 1769 }
1734 1770
1735 return fin >= 0; 1771 return fin >= 0;
1736
1737#else
1738 return 1;
1739#endif
1740} 1772}
1741 1773
1742static void 1774ecb_cold static void
1743file_pop (SCHEME_P) 1775file_pop (SCHEME_P)
1744{ 1776{
1745 if (SCHEME_V->file_i != 0) 1777 if (SCHEME_V->file_i != 0)
1746 { 1778 {
1747 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1779 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
… …
1751 SCHEME_V->file_i--; 1783 SCHEME_V->file_i--;
1752 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i); 1784 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1753 } 1785 }
1754} 1786}
1755 1787
1756static int 1788ecb_cold static int
1757file_interactive (SCHEME_P) 1789file_interactive (SCHEME_P)
1758{ 1790{
1759#if USE_PORTS 1791#if USE_PORTS
1760 return SCHEME_V->file_i == 0 1792 return SCHEME_V->file_i == 0
1761 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1793 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
… …
1764 return 0; 1796 return 0;
1765#endif 1797#endif
1766} 1798}
1767 1799
1768#if USE_PORTS 1800#if USE_PORTS
1769static port * 1801ecb_cold static port *
1770port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1802port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1771{ 1803{
1772 int fd; 1804 int fd;
1773 int flags; 1805 int flags;
1774 char *rw; 1806 char *rw;
… …
1797# endif 1829# endif
1798 1830
1799 return pt; 1831 return pt;
1800} 1832}
1801 1833
1802static pointer 1834ecb_cold static pointer
1803port_from_filename (SCHEME_P_ const char *fn, int prop) 1835port_from_filename (SCHEME_P_ const char *fn, int prop)
1804{ 1836{
1805 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1837 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1806 1838
1807 if (!pt && USE_ERROR_CHECKING) 1839 if (!pt && USE_ERROR_CHECKING)
1808 return NIL; 1840 return NIL;
1809 1841
1810 return mk_port (SCHEME_A_ pt); 1842 return mk_port (SCHEME_A_ pt);
1811} 1843}
1812 1844
1813static port * 1845ecb_cold static port *
1814port_rep_from_file (SCHEME_P_ int f, int prop) 1846port_rep_from_file (SCHEME_P_ int f, int prop)
1815{ 1847{
1816 port *pt = malloc (sizeof *pt); 1848 port *pt = malloc (sizeof *pt);
1817 1849
1818 if (!pt && USE_ERROR_CHECKING) 1850 if (!pt && USE_ERROR_CHECKING)
… …
1823 pt->rep.stdio.file = f; 1855 pt->rep.stdio.file = f;
1824 pt->rep.stdio.closeit = 0; 1856 pt->rep.stdio.closeit = 0;
1825 return pt; 1857 return pt;
1826} 1858}
1827 1859
1828static pointer 1860ecb_cold static pointer
1829port_from_file (SCHEME_P_ int f, int prop) 1861port_from_file (SCHEME_P_ int f, int prop)
1830{ 1862{
1831 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1863 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1832 1864
1833 if (!pt && USE_ERROR_CHECKING) 1865 if (!pt && USE_ERROR_CHECKING)
1834 return NIL; 1866 return NIL;
1835 1867
1836 return mk_port (SCHEME_A_ pt); 1868 return mk_port (SCHEME_A_ pt);
1837} 1869}
1838 1870
1839static port * 1871ecb_cold static port *
1840port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1872port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1841{ 1873{
1842 port *pt = malloc (sizeof (port)); 1874 port *pt = malloc (sizeof (port));
1843 1875
1844 if (!pt && USE_ERROR_CHECKING) 1876 if (!pt && USE_ERROR_CHECKING)
… …
1850 pt->rep.string.curr = start; 1882 pt->rep.string.curr = start;
1851 pt->rep.string.past_the_end = past_the_end; 1883 pt->rep.string.past_the_end = past_the_end;
1852 return pt; 1884 return pt;
1853} 1885}
1854 1886
1855static pointer 1887ecb_cold static pointer
1856port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1888port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1857{ 1889{
1858 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1890 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1859 1891
1860 if (!pt && USE_ERROR_CHECKING) 1892 if (!pt && USE_ERROR_CHECKING)
… …
1863 return mk_port (SCHEME_A_ pt); 1895 return mk_port (SCHEME_A_ pt);
1864} 1896}
1865 1897
1866# define BLOCK_SIZE 256 1898# define BLOCK_SIZE 256
1867 1899
1868static port * 1900ecb_cold static port *
1869port_rep_from_scratch (SCHEME_P) 1901port_rep_from_scratch (SCHEME_P)
1870{ 1902{
1871 char *start; 1903 char *start;
1872 port *pt = malloc (sizeof (port)); 1904 port *pt = malloc (sizeof (port));
1873 1905
… …
1887 pt->rep.string.curr = start; 1919 pt->rep.string.curr = start;
1888 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1920 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1889 return pt; 1921 return pt;
1890} 1922}
1891 1923
1892static pointer 1924ecb_cold static pointer
1893port_from_scratch (SCHEME_P) 1925port_from_scratch (SCHEME_P)
1894{ 1926{
1895 port *pt = port_rep_from_scratch (SCHEME_A); 1927 port *pt = port_rep_from_scratch (SCHEME_A);
1896 1928
1897 if (!pt && USE_ERROR_CHECKING) 1929 if (!pt && USE_ERROR_CHECKING)
1898 return NIL; 1930 return NIL;
1899 1931
1900 return mk_port (SCHEME_A_ pt); 1932 return mk_port (SCHEME_A_ pt);
1901} 1933}
1902 1934
1903static void 1935ecb_cold static void
1904port_close (SCHEME_P_ pointer p, int flag) 1936port_close (SCHEME_P_ pointer p, int flag)
1905{ 1937{
1906 port *pt = port (p); 1938 port *pt = port (p);
1907 1939
1908 pt->kind &= ~flag; 1940 pt->kind &= ~flag;
… …
1928 } 1960 }
1929} 1961}
1930#endif 1962#endif
1931 1963
1932/* get new character from input file */ 1964/* get new character from input file */
1933static int 1965ecb_cold static int
1934inchar (SCHEME_P) 1966inchar (SCHEME_P)
1935{ 1967{
1936 int c; 1968 int c;
1937 port *pt = port (SCHEME_V->inport); 1969 port *pt = port (SCHEME_V->inport);
1938 1970
… …
1952 } 1984 }
1953 1985
1954 return c; 1986 return c;
1955} 1987}
1956 1988
1957static int ungot = -1; 1989ecb_cold static int
1958
1959static int
1960basic_inchar (port *pt) 1990basic_inchar (port *pt)
1961{ 1991{
1962#if USE_PORTS
1963 if (pt->unget != -1) 1992 if (pt->unget != -1)
1964 { 1993 {
1965 int r = pt->unget; 1994 int r = pt->unget;
1966 pt->unget = -1; 1995 pt->unget = -1;
1967 return r; 1996 return r;
1968 } 1997 }
1969 1998
1999#if USE_PORTS
1970 if (pt->kind & port_file) 2000 if (pt->kind & port_file)
1971 { 2001 {
1972 char c; 2002 char c;
1973 2003
1974 if (!read (pt->rep.stdio.file, &c, 1)) 2004 if (!read (pt->rep.stdio.file, &c, 1))
… …
1982 return EOF; 2012 return EOF;
1983 else 2013 else
1984 return *pt->rep.string.curr++; 2014 return *pt->rep.string.curr++;
1985 } 2015 }
1986#else 2016#else
1987 if (ungot == -1)
1988 {
1989 char c; 2017 char c;
1990 if (!read (0, &c, 1)) 2018
2019 if (!read (pt->rep.stdio.file, &c, 1))
1991 return EOF; 2020 return EOF;
1992 2021
1993 ungot = c;
1994 }
1995
1996 {
1997 int r = ungot;
1998 ungot = -1;
1999 return r; 2022 return c;
2000 }
2001#endif 2023#endif
2002} 2024}
2003 2025
2004/* back character to input buffer */ 2026/* back character to input buffer */
2005static void 2027ecb_cold static void
2006backchar (SCHEME_P_ int c) 2028backchar (SCHEME_P_ int c)
2007{ 2029{
2008#if USE_PORTS 2030 port *pt = port (SCHEME_V->inport);
2009 port *pt;
2010 2031
2011 if (c == EOF) 2032 if (c == EOF)
2012 return; 2033 return;
2013 2034
2014 pt = port (SCHEME_V->inport);
2015 pt->unget = c; 2035 pt->unget = c;
2016#else
2017 if (c == EOF)
2018 return;
2019
2020 ungot = c;
2021#endif
2022} 2036}
2023 2037
2024#if USE_PORTS 2038#if USE_PORTS
2025static int 2039ecb_cold static int
2026realloc_port_string (SCHEME_P_ port *p) 2040realloc_port_string (SCHEME_P_ port *p)
2027{ 2041{
2028 char *start = p->rep.string.start; 2042 char *start = p->rep.string.start;
2029 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2043 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2030 char *str = malloc (new_size); 2044 char *str = malloc (new_size);
… …
2043 else 2057 else
2044 return 0; 2058 return 0;
2045} 2059}
2046#endif 2060#endif
2047 2061
2048INTERFACE void 2062ecb_cold static void
2049putstr (SCHEME_P_ const char *s) 2063putchars (SCHEME_P_ const char *s, int len)
2050{ 2064{
2065 port *pt = port (SCHEME_V->outport);
2066
2051#if USE_PORTS 2067#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) 2068 if (pt->kind & port_file)
2075 write (pt->rep.stdio.file, s, len); 2069 write (pt->rep.stdio.file, s, len);
2076 else 2070 else
2077 { 2071 {
2078 for (; len; len--) 2072 for (; len; len--)
… …
2083 *pt->rep.string.curr++ = *s++; 2077 *pt->rep.string.curr++ = *s++;
2084 } 2078 }
2085 } 2079 }
2086 2080
2087#else 2081#else
2088 write (1, s, len); 2082 write (1, s, len); // output not initialised
2089#endif 2083#endif
2084}
2085
2086INTERFACE void
2087putstr (SCHEME_P_ const char *s)
2088{
2089 putchars (SCHEME_A_ s, strlen (s));
2090} 2090}
2091 2091
2092INTERFACE void 2092INTERFACE void
2093putcharacter (SCHEME_P_ int c) 2093putcharacter (SCHEME_P_ int c)
2094{ 2094{
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; 2095 char cc = c;
2113 write (1, &c, 1); 2096
2114#endif 2097 putchars (SCHEME_A_ &cc, 1);
2115} 2098}
2116 2099
2117/* read characters up to delimiter, but cater to character constants */ 2100/* read characters up to delimiter, but cater to character constants */
2118static char * 2101ecb_cold static char *
2119readstr_upto (SCHEME_P_ int skip, const char *delim) 2102readstr_upto (SCHEME_P_ int skip, const char *delim)
2120{ 2103{
2121 char *p = SCHEME_V->strbuff + skip; 2104 char *p = SCHEME_V->strbuff + skip;
2122 2105
2123 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2106 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
… …
2132 2115
2133 return SCHEME_V->strbuff; 2116 return SCHEME_V->strbuff;
2134} 2117}
2135 2118
2136/* read string expression "xxx...xxx" */ 2119/* read string expression "xxx...xxx" */
2137static pointer 2120ecb_cold static pointer
2138readstrexp (SCHEME_P_ char delim) 2121readstrexp (SCHEME_P_ char delim)
2139{ 2122{
2140 char *p = SCHEME_V->strbuff; 2123 char *p = SCHEME_V->strbuff;
2141 int c; 2124 int c;
2142 int c1 = 0; 2125 int c1 = 0;
… …
2175 case '7': 2158 case '7':
2176 state = st_oct1; 2159 state = st_oct1;
2177 c1 = c - '0'; 2160 c1 = c - '0';
2178 break; 2161 break;
2179 2162
2163 case 'a': *p++ = '\a'; state = st_ok; break;
2164 case 'n': *p++ = '\n'; state = st_ok; break;
2165 case 'r': *p++ = '\r'; state = st_ok; break;
2166 case 't': *p++ = '\t'; state = st_ok; break;
2167
2168 // this overshoots the minimum requirements of r7rs
2169 case ' ':
2170 case '\t':
2171 case '\r':
2172 case '\n':
2173 skipspace (SCHEME_A);
2174 state = st_ok;
2175 break;
2176
2177 //TODO: x should end in ;, not two-digit hex
2180 case 'x': 2178 case 'x':
2181 case 'X': 2179 case 'X':
2182 state = st_x1; 2180 state = st_x1;
2183 c1 = 0; 2181 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; 2182 break;
2200 2183
2201 default: 2184 default:
2202 *p++ = c; 2185 *p++ = c;
2203 state = st_ok; 2186 state = st_ok;
… …
2255 } 2238 }
2256 } 2239 }
2257} 2240}
2258 2241
2259/* check c is in chars */ 2242/* check c is in chars */
2260ecb_inline int 2243ecb_cold int
2261is_one_of (const char *s, int c) 2244is_one_of (const char *s, int c)
2262{ 2245{
2263 return c == EOF || !!strchr (s, c); 2246 return c == EOF || !!strchr (s, c);
2264} 2247}
2265 2248
2266/* skip white characters */ 2249/* skip white characters */
2267ecb_inline int 2250ecb_cold int
2268skipspace (SCHEME_P) 2251skipspace (SCHEME_P)
2269{ 2252{
2270 int c, curr_line = 0; 2253 int c, curr_line = 0;
2271 2254
2272 do 2255 do
… …
2292 backchar (SCHEME_A_ c); 2275 backchar (SCHEME_A_ c);
2293 return 1; 2276 return 1;
2294} 2277}
2295 2278
2296/* get token */ 2279/* get token */
2297static int 2280ecb_cold static int
2298token (SCHEME_P) 2281token (SCHEME_P)
2299{ 2282{
2300 int c = skipspace (SCHEME_A); 2283 int c = skipspace (SCHEME_A);
2301 2284
2302 if (c == EOF) 2285 if (c == EOF)
… …
2400} 2383}
2401 2384
2402/* ========== Routines for Printing ========== */ 2385/* ========== Routines for Printing ========== */
2403#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2386#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2404 2387
2405static void 2388ecb_cold static void
2406printslashstring (SCHEME_P_ char *p, int len) 2389printslashstring (SCHEME_P_ char *p, int len)
2407{ 2390{
2408 int i; 2391 int i;
2409 unsigned char *s = (unsigned char *) p; 2392 unsigned char *s = (unsigned char *) p;
2410 2393
… …
2466 2449
2467 putcharacter (SCHEME_A_ '"'); 2450 putcharacter (SCHEME_A_ '"');
2468} 2451}
2469 2452
2470/* print atoms */ 2453/* print atoms */
2471static void 2454ecb_cold static void
2472printatom (SCHEME_P_ pointer l, int f) 2455printatom (SCHEME_P_ pointer l, int f)
2473{ 2456{
2474 char *p; 2457 char *p;
2475 int len; 2458 int len;
2476 2459
2477 atom2str (SCHEME_A_ l, f, &p, &len); 2460 atom2str (SCHEME_A_ l, f, &p, &len);
2478 putchars (SCHEME_A_ p, len); 2461 putchars (SCHEME_A_ p, len);
2479} 2462}
2480 2463
2481/* Uses internal buffer unless string pointer is already available */ 2464/* Uses internal buffer unless string pointer is already available */
2482static void 2465ecb_cold static void
2483atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2466atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2484{ 2467{
2485 char *p; 2468 char *p;
2486 2469
2487 if (l == NIL) 2470 if (l == NIL)
… …
2694 return car (d); 2677 return car (d);
2695 2678
2696 p = cons (car (d), cdr (d)); 2679 p = cons (car (d), cdr (d));
2697 q = p; 2680 q = p;
2698 2681
2699 while (cdr (cdr (p)) != NIL) 2682 while (cddr (p) != NIL)
2700 { 2683 {
2701 d = cons (car (p), cdr (p)); 2684 d = cons (car (p), cdr (p));
2702 2685
2703 if (cdr (cdr (p)) != NIL) 2686 if (cddr (p) != NIL)
2704 p = cdr (d); 2687 p = cdr (d);
2705 } 2688 }
2706 2689
2707 set_cdr (p, car (cdr (p))); 2690 set_cdr (p, cadr (p));
2708 return q; 2691 return q;
2709} 2692}
2710 2693
2711/* reverse list -- produce new list */ 2694/* reverse list -- produce new list */
2712static pointer 2695ecb_hot static pointer
2713reverse (SCHEME_P_ pointer a) 2696reverse (SCHEME_P_ pointer a)
2714{ 2697{
2715 /* a must be checked by gc */ 2698 /* a must be checked by gc */
2716 pointer p = NIL; 2699 pointer p = NIL;
2717 2700
… …
2720 2703
2721 return p; 2704 return p;
2722} 2705}
2723 2706
2724/* reverse list --- in-place */ 2707/* reverse list --- in-place */
2725static pointer 2708ecb_hot static pointer
2726reverse_in_place (SCHEME_P_ pointer term, pointer list) 2709reverse_in_place (SCHEME_P_ pointer term, pointer list)
2727{ 2710{
2728 pointer result = term; 2711 pointer result = term;
2729 pointer p = list; 2712 pointer p = list;
2730 2713
… …
2738 2721
2739 return result; 2722 return result;
2740} 2723}
2741 2724
2742/* append list -- produce new list (in reverse order) */ 2725/* append list -- produce new list (in reverse order) */
2743static pointer 2726ecb_hot static pointer
2744revappend (SCHEME_P_ pointer a, pointer b) 2727revappend (SCHEME_P_ pointer a, pointer b)
2745{ 2728{
2746 pointer result = a; 2729 pointer result = a;
2747 pointer p = b; 2730 pointer p = b;
2748 2731
… …
2757 2740
2758 return S_F; /* signal an error */ 2741 return S_F; /* signal an error */
2759} 2742}
2760 2743
2761/* equivalence of atoms */ 2744/* equivalence of atoms */
2762int 2745ecb_hot int
2763eqv (pointer a, pointer b) 2746eqv (pointer a, pointer b)
2764{ 2747{
2765 if (is_string (a)) 2748 if (is_string (a))
2766 { 2749 {
2767 if (is_string (b)) 2750 if (is_string (b))
… …
2861 } 2844 }
2862 else 2845 else
2863 set_car (env, immutable_cons (slot, car (env))); 2846 set_car (env, immutable_cons (slot, car (env)));
2864} 2847}
2865 2848
2866static pointer 2849ecb_hot static pointer
2867find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2850find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2868{ 2851{
2869 pointer x, y; 2852 pointer x, y;
2870 2853
2871 for (x = env; x != NIL; x = cdr (x)) 2854 for (x = env; x != NIL; x = cdr (x))
… …
2892 return NIL; 2875 return NIL;
2893} 2876}
2894 2877
2895#else /* USE_ALIST_ENV */ 2878#else /* USE_ALIST_ENV */
2896 2879
2897ecb_inline void 2880static void
2898new_frame_in_env (SCHEME_P_ pointer old_env) 2881new_frame_in_env (SCHEME_P_ pointer old_env)
2899{ 2882{
2900 SCHEME_V->envir = immutable_cons (NIL, old_env); 2883 SCHEME_V->envir = immutable_cons (NIL, old_env);
2901 setenvironment (SCHEME_V->envir); 2884 setenvironment (SCHEME_V->envir);
2902} 2885}
2903 2886
2904ecb_inline void 2887static void
2905new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2888new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2906{ 2889{
2907 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2890 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2908} 2891}
2909 2892
2910static pointer 2893ecb_hot static pointer
2911find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2894find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2912{ 2895{
2913 pointer x, y; 2896 pointer x, y;
2914 2897
2915 for (x = env; x != NIL; x = cdr (x)) 2898 for (x = env; x != NIL; x = cdr (x))
… …
2929 return NIL; 2912 return NIL;
2930} 2913}
2931 2914
2932#endif /* USE_ALIST_ENV else */ 2915#endif /* USE_ALIST_ENV else */
2933 2916
2934ecb_inline void 2917static void
2935new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2918new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2936{ 2919{
2937 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 2920 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2938 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2921 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2939} 2922}
2940 2923
2941ecb_inline void 2924static void
2942set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2925set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2943{ 2926{
2944 set_cdr (slot, value); 2927 set_cdr (slot, value);
2945} 2928}
2946 2929
2947ecb_inline pointer 2930static pointer
2948slot_value_in_env (pointer slot) 2931slot_value_in_env (pointer slot)
2949{ 2932{
2950 return cdr (slot); 2933 return cdr (slot);
2951} 2934}
2952 2935
2953/* ========== Evaluation Cycle ========== */ 2936/* ========== Evaluation Cycle ========== */
2954 2937
2955static int 2938ecb_cold static int
2956xError_1 (SCHEME_P_ const char *s, pointer a) 2939xError_1 (SCHEME_P_ const char *s, pointer a)
2957{ 2940{
2958#if USE_ERROR_HOOK 2941#if USE_ERROR_HOOK
2959 pointer x; 2942 pointer x;
2960 pointer hdl = SCHEME_V->ERROR_HOOK; 2943 pointer hdl = SCHEME_V->ERROR_HOOK;
… …
3036 pointer code; 3019 pointer code;
3037}; 3020};
3038 3021
3039# define STACK_GROWTH 3 3022# define STACK_GROWTH 3
3040 3023
3041static void 3024ecb_hot static void
3042s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3025s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3043{ 3026{
3044 int nframes = (uintptr_t)SCHEME_V->dump; 3027 int nframes = (uintptr_t)SCHEME_V->dump;
3045 struct dump_stack_frame *next_frame; 3028 struct dump_stack_frame *next_frame;
3046 3029
… …
3059 next_frame->code = code; 3042 next_frame->code = code;
3060 3043
3061 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3044 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3062} 3045}
3063 3046
3064static int 3047static ecb_hot int
3065xs_return (SCHEME_P_ pointer a) 3048xs_return (SCHEME_P_ pointer a)
3066{ 3049{
3067 int nframes = (uintptr_t)SCHEME_V->dump; 3050 int nframes = (uintptr_t)SCHEME_V->dump;
3068 struct dump_stack_frame *frame; 3051 struct dump_stack_frame *frame;
3069 3052
… …
3080 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3063 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3081 3064
3082 return 0; 3065 return 0;
3083} 3066}
3084 3067
3085ecb_inline void 3068ecb_cold void
3086dump_stack_reset (SCHEME_P) 3069dump_stack_reset (SCHEME_P)
3087{ 3070{
3088 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3071 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3089 SCHEME_V->dump = (pointer)+0; 3072 SCHEME_V->dump = (pointer)+0;
3090} 3073}
3091 3074
3092ecb_inline void 3075ecb_cold void
3093dump_stack_initialize (SCHEME_P) 3076dump_stack_initialize (SCHEME_P)
3094{ 3077{
3095 SCHEME_V->dump_size = 0; 3078 SCHEME_V->dump_size = 0;
3096 SCHEME_V->dump_base = 0; 3079 SCHEME_V->dump_base = 0;
3097 dump_stack_reset (SCHEME_A); 3080 dump_stack_reset (SCHEME_A);
3098} 3081}
3099 3082
3100static void 3083ecb_cold static void
3101dump_stack_free (SCHEME_P) 3084dump_stack_free (SCHEME_P)
3102{ 3085{
3103 free (SCHEME_V->dump_base); 3086 free (SCHEME_V->dump_base);
3104 SCHEME_V->dump_base = 0; 3087 SCHEME_V->dump_base = 0;
3105 SCHEME_V->dump = (pointer)0; 3088 SCHEME_V->dump = (pointer)0;
3106 SCHEME_V->dump_size = 0; 3089 SCHEME_V->dump_size = 0;
3107} 3090}
3108 3091
3109static void 3092ecb_cold static void
3110dump_stack_mark (SCHEME_P) 3093dump_stack_mark (SCHEME_P)
3111{ 3094{
3112 int nframes = (uintptr_t)SCHEME_V->dump; 3095 int nframes = (uintptr_t)SCHEME_V->dump;
3113 int i; 3096 int i;
3114 3097
… …
3120 mark (frame->envir); 3103 mark (frame->envir);
3121 mark (frame->code); 3104 mark (frame->code);
3122 } 3105 }
3123} 3106}
3124 3107
3125static pointer 3108ecb_cold static pointer
3126ss_get_cont (SCHEME_P) 3109ss_get_cont (SCHEME_P)
3127{ 3110{
3128 int nframes = (uintptr_t)SCHEME_V->dump; 3111 int nframes = (uintptr_t)SCHEME_V->dump;
3129 int i; 3112 int i;
3130 3113
… …
3142 } 3125 }
3143 3126
3144 return cont; 3127 return cont;
3145} 3128}
3146 3129
3147static void 3130ecb_cold static void
3148ss_set_cont (SCHEME_P_ pointer cont) 3131ss_set_cont (SCHEME_P_ pointer cont)
3149{ 3132{
3150 int i = 0; 3133 int i = 0;
3151 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3134 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3152 3135
… …
3164 SCHEME_V->dump = (pointer)(uintptr_t)i; 3147 SCHEME_V->dump = (pointer)(uintptr_t)i;
3165} 3148}
3166 3149
3167#else 3150#else
3168 3151
3169ecb_inline void 3152ecb_cold void
3170dump_stack_reset (SCHEME_P) 3153dump_stack_reset (SCHEME_P)
3171{ 3154{
3172 SCHEME_V->dump = NIL; 3155 SCHEME_V->dump = NIL;
3173} 3156}
3174 3157
3175ecb_inline void 3158ecb_cold void
3176dump_stack_initialize (SCHEME_P) 3159dump_stack_initialize (SCHEME_P)
3177{ 3160{
3178 dump_stack_reset (SCHEME_A); 3161 dump_stack_reset (SCHEME_A);
3179} 3162}
3180 3163
3181static void 3164ecb_cold static void
3182dump_stack_free (SCHEME_P) 3165dump_stack_free (SCHEME_P)
3183{ 3166{
3184 SCHEME_V->dump = NIL; 3167 SCHEME_V->dump = NIL;
3185} 3168}
3186 3169
3187static int 3170ecb_hot static int
3188xs_return (SCHEME_P_ pointer a) 3171xs_return (SCHEME_P_ pointer a)
3189{ 3172{
3190 pointer dump = SCHEME_V->dump; 3173 pointer dump = SCHEME_V->dump;
3191 3174
3192 SCHEME_V->value = a; 3175 SCHEME_V->value = a;
… …
3202 SCHEME_V->dump = dump; 3185 SCHEME_V->dump = dump;
3203 3186
3204 return 0; 3187 return 0;
3205} 3188}
3206 3189
3207static void 3190ecb_hot static void
3208s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3191s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3209{ 3192{
3210 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3193 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3211 cons (args, 3194 cons (args,
3212 cons (SCHEME_V->envir, 3195 cons (SCHEME_V->envir,
3213 cons (code, 3196 cons (code,
3214 SCHEME_V->dump)))); 3197 SCHEME_V->dump))));
3215} 3198}
3216 3199
3200ecb_cold static void
3201dump_stack_mark (SCHEME_P)
3202{
3203 mark (SCHEME_V->dump);
3204}
3205
3206ecb_cold static pointer
3207ss_get_cont (SCHEME_P)
3208{
3209 return SCHEME_V->dump;
3210}
3211
3212ecb_cold static void
3213ss_set_cont (SCHEME_P_ pointer cont)
3214{
3215 SCHEME_V->dump = cont;
3216}
3217
3218#endif
3219
3220#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3221
3222#if EXPERIMENT
3223
3224typedef void *stream[1];
3225
3226#define stream_init() { 0 }
3227
3228ecb_cold static void
3229stream_put (void **s, uint8_t byte)
3230{
3231 uint32_t *sp = *s;
3232 uint32_t size = sizeof (uint32_t) * 2;
3233 uint32_t offs = size;
3234
3235 if (ecb_expect_true (sp))
3236 {
3237 offs = sp[0];
3238 size = sp[1];
3239 }
3240
3241 if (ecb_expect_false (offs == size))
3242 {
3243 size *= 2;
3244 sp = realloc (sp, size);
3245 *s = sp;
3246 sp[1] = size;
3247
3248 }
3249
3250 ((uint8_t *)sp)[offs++] = byte;
3251 sp[0] = offs;
3252}
3253
3254#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
3255#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
3256#define stream_free(s) free (s[0])
3257
3258// calculates a (preferably small) integer that makes it possible to find
3259// the symbol again. if pointers were offsets into a memory area... until
3260// then, we return segment number in the low bits, and offset in the high
3261// bits
3262static uint32_t
3263symbol_id (SCHEME_P_ pointer sym)
3264{
3265 struct cell *p = CELL (sym);
3266 int i;
3267
3268 for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3269 if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3270 {
3271 printf ("seg %d ofs %d/%d\n",i,(p - SCHEME_V->cell_seg[i]),SCHEME_V->cell_segsize[i]);//D
3272 return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3273 }
3274
3275 abort ();
3276}
3277
3217static void 3278static void
3218dump_stack_mark (SCHEME_P) 3279compile (SCHEME_P_ stream s, pointer x)
3219{ 3280{
3220 mark (SCHEME_V->dump); 3281 if (x == NIL)
3221} 3282 {
3283 stream_put (s, 0);
3284 return;
3285 }
3222 3286
3223static pointer 3287 if (is_syntax (x))
3224ss_get_cont (SCHEME_P) 3288 {
3225{ 3289 stream_put (s, 1);
3226 return SCHEME_V->dump; 3290 stream_put (s, syntaxnum (x));
3227} 3291 return;
3292 }
3228 3293
3229static void 3294 switch (type (x))
3230ss_set_cont (SCHEME_P_ pointer cont) 3295 {
3231{ 3296 case T_INTEGER:
3232 SCHEME_V->dump = cont; 3297 stream_put (s, 2);
3233} 3298 stream_put (s, 0);
3299 stream_put (s, 0);
3300 stream_put (s, 0);
3301 stream_put (s, 0);
3302 return;
3234 3303
3235#endif 3304 case T_SYMBOL:
3305 {
3306 uint32_t sym = symbol_id (SCHEME_A_ x);
3307 printf ("sym %x\n", sym);//D
3236 3308
3237#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3309 stream_put (s, 3);
3238 3310
3239#if EXPERIMENT 3311 while (sym > 0x7f)
3312 {
3313 stream_put (s, sym | 0x80);
3314 sym >>= 8;
3315 }
3316
3317 stream_put (s, sym);
3318 }
3319 return;
3320
3321 case T_PAIR:
3322 stream_put (s, 4);
3323 while (x != NIL)
3324 {
3325 compile (SCHEME_A_ s, car (x));
3326 x = cdr (x);
3327 }
3328 stream_put (s, 0xff);
3329 return;
3330
3331 default:
3332 stream_put (s, 5);
3333 stream_put (s, type (x));
3334 stream_put (s, 0);
3335 stream_put (s, 0);
3336 stream_put (s, 0);
3337 stream_put (s, 0);
3338 break;
3339 }
3340}
3341
3240static int 3342static int
3343compile_closure (SCHEME_P_ pointer p)
3344{
3345 stream s = stream_init ();
3346
3347 printatom (SCHEME_A_ p, 1);//D
3348 compile (SCHEME_A_ s, car (p));
3349
3350 FILE *xxd = popen ("xxd", "we");
3351 fwrite (stream_data (s), 1, stream_size (s), xxd);
3352 fclose (xxd);
3353
3354 return stream_size (s);
3355}
3356
3357static int
3241debug (SCHEME_P_ int indent, pointer x) 3358dtree (SCHEME_P_ int indent, pointer x)
3242{ 3359{
3243 int c; 3360 int c;
3244 3361
3245 if (is_syntax (x)) 3362 if (is_syntax (x))
3246 { 3363 {
… …
3264 printf ("%*sS<%s>\n", indent, "", symname (x)); 3381 printf ("%*sS<%s>\n", indent, "", symname (x));
3265 return 24+8; 3382 return 24+8;
3266 3383
3267 case T_CLOSURE: 3384 case T_CLOSURE:
3268 printf ("%*sS<%s>\n", indent, "", "closure"); 3385 printf ("%*sS<%s>\n", indent, "", "closure");
3269 debug (SCHEME_A_ indent + 3, cdr(x)); 3386 dtree (SCHEME_A_ indent + 3, cdr(x));
3270 return 32 + debug (SCHEME_A_ indent + 3, car (x)); 3387 return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3271 3388
3272 case T_PAIR: 3389 case T_PAIR:
3273 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); 3390 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3274 c = debug (SCHEME_A_ indent + 3, car (x)); 3391 c = dtree (SCHEME_A_ indent + 3, car (x));
3275 c += debug (SCHEME_A_ indent + 3, cdr (x)); 3392 c += dtree (SCHEME_A_ indent + 3, cdr (x));
3276 return c + 1; 3393 return c + 1;
3277 3394
3278 case T_PORT: 3395 case T_PORT:
3279 printf ("%*sS<%s>\n", indent, "", "port"); 3396 printf ("%*sS<%s>\n", indent, "", "port");
3280 return 24+8; 3397 return 24+8;
… …
3283 printf ("%*sS<%s>\n", indent, "", "vector"); 3400 printf ("%*sS<%s>\n", indent, "", "vector");
3284 return 24+8; 3401 return 24+8;
3285 3402
3286 case T_ENVIRONMENT: 3403 case T_ENVIRONMENT:
3287 printf ("%*sS<%s>\n", indent, "", "environment"); 3404 printf ("%*sS<%s>\n", indent, "", "environment");
3288 return 0 + debug (SCHEME_A_ indent + 3, car (x)); 3405 return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3289 3406
3290 default: 3407 default:
3291 printf ("unhandled type %d\n", type (x)); 3408 printf ("unhandled type %d\n", type (x));
3292 break; 3409 break;
3293 } 3410 }
3294} 3411}
3295#endif 3412#endif
3296 3413
3297static int 3414/* syntax, eval, core, ... */
3415ecb_hot static int
3298opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3416opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3299{ 3417{
3300 pointer args = SCHEME_V->args; 3418 pointer args = SCHEME_V->args;
3301 pointer x, y; 3419 pointer x, y;
3302 3420
3303 switch (op) 3421 switch (op)
3304 { 3422 {
3305#if EXPERIMENT //D 3423#if EXPERIMENT //D
3306 case OP_DEBUG: 3424 case OP_DEBUG:
3307 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3425 {
3426 uint32_t len = compile_closure (SCHEME_A_ car (args));
3427 printf ("len = %d\n", len);
3308 printf ("\n"); 3428 printf ("\n");
3309 s_return (S_T); 3429 s_return (S_T);
3430 }
3310#endif 3431#endif
3311 case OP_LOAD: /* load */ 3432 case OP_LOAD: /* load */
3312 if (file_interactive (SCHEME_A)) 3433 if (file_interactive (SCHEME_A))
3313 { 3434 {
3314 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n"); 3435 putstr (SCHEME_A_ "Loading ");
3315 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3436 putstr (SCHEME_A_ strvalue (car (args)));
3437 putcharacter (SCHEME_A_ '\n');
3316 } 3438 }
3317 3439
3318 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3440 if (!file_push (SCHEME_A_ strvalue (car (args))))
3319 Error_1 ("unable to open", car (args)); 3441 Error_1 ("unable to open", car (args));
3320 else 3442
3321 {
3322 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3443 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3323 s_goto (OP_T0LVL); 3444 s_goto (OP_T0LVL);
3324 }
3325 3445
3326 case OP_T0LVL: /* top level */ 3446 case OP_T0LVL: /* top level */
3327 3447
3328 /* If we reached the end of file, this loop is done. */ 3448 /* If we reached the end of file, this loop is done. */
3329 if (port (SCHEME_V->loadport)->kind & port_saw_EOF) 3449 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
… …
3345 /* If interactive, be nice to user. */ 3465 /* If interactive, be nice to user. */
3346 if (file_interactive (SCHEME_A)) 3466 if (file_interactive (SCHEME_A))
3347 { 3467 {
3348 SCHEME_V->envir = SCHEME_V->global_env; 3468 SCHEME_V->envir = SCHEME_V->global_env;
3349 dump_stack_reset (SCHEME_A); 3469 dump_stack_reset (SCHEME_A);
3350 putstr (SCHEME_A_ "\n"); 3470 putcharacter (SCHEME_A_ '\n');
3351 putstr (SCHEME_A_ prompt); 3471 putstr (SCHEME_A_ prompt);
3352 } 3472 }
3353 3473
3354 /* Set up another iteration of REPL */ 3474 /* Set up another iteration of REPL */
3355 SCHEME_V->nesting = 0; 3475 SCHEME_V->nesting = 0;
… …
3390 { 3510 {
3391 SCHEME_V->print_flag = 1; 3511 SCHEME_V->print_flag = 1;
3392 SCHEME_V->args = SCHEME_V->value; 3512 SCHEME_V->args = SCHEME_V->value;
3393 s_goto (OP_P0LIST); 3513 s_goto (OP_P0LIST);
3394 } 3514 }
3395 else 3515
3396 s_return (SCHEME_V->value); 3516 s_return (SCHEME_V->value);
3397 3517
3398 case OP_EVAL: /* main part of evaluation */ 3518 case OP_EVAL: /* main part of evaluation */
3399#if USE_TRACING 3519#if USE_TRACING
3400 if (SCHEME_V->tracing) 3520 if (SCHEME_V->tracing)
3401 { 3521 {
… …
3434 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3554 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3435 SCHEME_V->code = x; 3555 SCHEME_V->code = x;
3436 s_goto (OP_EVAL); 3556 s_goto (OP_EVAL);
3437 } 3557 }
3438 } 3558 }
3439 else 3559
3440 s_return (SCHEME_V->code); 3560 s_return (SCHEME_V->code);
3441 3561
3442 case OP_E0ARGS: /* eval arguments */ 3562 case OP_E0ARGS: /* eval arguments */
3443 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ 3563 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3444 { 3564 {
3445 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3565 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
… …
3617 else 3737 else
3618 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 3738 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3619 3739
3620 s_return (SCHEME_V->code); 3740 s_return (SCHEME_V->code);
3621 3741
3622
3623 case OP_DEFP: /* defined? */ 3742 case OP_DEFP: /* defined? */
3624 x = SCHEME_V->envir; 3743 x = SCHEME_V->envir;
3625 3744
3626 if (cdr (args) != NIL) 3745 if (cdr (args) != NIL)
3627 x = cadr (args); 3746 x = cadr (args);
… …
3644 set_slot_in_env (SCHEME_A_ y, SCHEME_V->value); 3763 set_slot_in_env (SCHEME_A_ y, SCHEME_V->value);
3645 s_return (SCHEME_V->value); 3764 s_return (SCHEME_V->value);
3646 } 3765 }
3647 else 3766 else
3648 Error_1 ("set!: unbound variable:", SCHEME_V->code); 3767 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3649
3650 3768
3651 case OP_BEGIN: /* begin */ 3769 case OP_BEGIN: /* begin */
3652 if (!is_pair (SCHEME_V->code)) 3770 if (!is_pair (SCHEME_V->code))
3653 s_return (SCHEME_V->code); 3771 s_return (SCHEME_V->code);
3654 3772
… …
3666 case OP_IF1: /* if */ 3784 case OP_IF1: /* if */
3667 if (is_true (SCHEME_V->value)) 3785 if (is_true (SCHEME_V->value))
3668 SCHEME_V->code = car (SCHEME_V->code); 3786 SCHEME_V->code = car (SCHEME_V->code);
3669 else 3787 else
3670 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ 3788 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
3789
3671 s_goto (OP_EVAL); 3790 s_goto (OP_EVAL);
3672 3791
3673 case OP_LET0: /* let */ 3792 case OP_LET0: /* let */
3674 SCHEME_V->args = NIL; 3793 SCHEME_V->args = NIL;
3675 SCHEME_V->value = SCHEME_V->code; 3794 SCHEME_V->value = SCHEME_V->code;
… …
3831 } 3950 }
3832 else 3951 else
3833 { 3952 {
3834 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) 3953 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3835 s_return (NIL); 3954 s_return (NIL);
3836 else 3955
3837 {
3838 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 3956 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3839 SCHEME_V->code = caar (SCHEME_V->code); 3957 SCHEME_V->code = caar (SCHEME_V->code);
3840 s_goto (OP_EVAL); 3958 s_goto (OP_EVAL);
3841 }
3842 } 3959 }
3843 3960
3844 case OP_DELAY: /* delay */ 3961 case OP_DELAY: /* delay */
3845 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 3962 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3846 set_typeflag (x, T_PROMISE); 3963 set_typeflag (x, T_PROMISE);
… …
3857 case OP_AND1: /* and */ 3974 case OP_AND1: /* and */
3858 if (is_false (SCHEME_V->value)) 3975 if (is_false (SCHEME_V->value))
3859 s_return (SCHEME_V->value); 3976 s_return (SCHEME_V->value);
3860 else if (SCHEME_V->code == NIL) 3977 else if (SCHEME_V->code == NIL)
3861 s_return (SCHEME_V->value); 3978 s_return (SCHEME_V->value);
3862 else 3979
3863 {
3864 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 3980 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3865 SCHEME_V->code = car (SCHEME_V->code); 3981 SCHEME_V->code = car (SCHEME_V->code);
3866 s_goto (OP_EVAL); 3982 s_goto (OP_EVAL);
3867 }
3868 3983
3869 case OP_OR0: /* or */ 3984 case OP_OR0: /* or */
3870 if (SCHEME_V->code == NIL) 3985 if (SCHEME_V->code == NIL)
3871 s_return (S_F); 3986 s_return (S_F);
3872 3987
… …
3877 case OP_OR1: /* or */ 3992 case OP_OR1: /* or */
3878 if (is_true (SCHEME_V->value)) 3993 if (is_true (SCHEME_V->value))
3879 s_return (SCHEME_V->value); 3994 s_return (SCHEME_V->value);
3880 else if (SCHEME_V->code == NIL) 3995 else if (SCHEME_V->code == NIL)
3881 s_return (SCHEME_V->value); 3996 s_return (SCHEME_V->value);
3882 else 3997
3883 {
3884 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 3998 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3885 SCHEME_V->code = car (SCHEME_V->code); 3999 SCHEME_V->code = car (SCHEME_V->code);
3886 s_goto (OP_EVAL); 4000 s_goto (OP_EVAL);
3887 }
3888 4001
3889 case OP_C0STREAM: /* cons-stream */ 4002 case OP_C0STREAM: /* cons-stream */
3890 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 4003 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3891 SCHEME_V->code = car (SCHEME_V->code); 4004 SCHEME_V->code = car (SCHEME_V->code);
3892 s_goto (OP_EVAL); 4005 s_goto (OP_EVAL);
… …
3957 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x)); 4070 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3958 SCHEME_V->code = caar (x); 4071 SCHEME_V->code = caar (x);
3959 s_goto (OP_EVAL); 4072 s_goto (OP_EVAL);
3960 } 4073 }
3961 } 4074 }
3962 else 4075
3963 s_return (NIL); 4076 s_return (NIL);
3964 4077
3965 case OP_CASE2: /* case */ 4078 case OP_CASE2: /* case */
3966 if (is_true (SCHEME_V->value)) 4079 if (is_true (SCHEME_V->value))
3967 s_goto (OP_BEGIN); 4080 s_goto (OP_BEGIN);
3968 else 4081
3969 s_return (NIL); 4082 s_return (NIL);
3970 4083
3971 case OP_PAPPLY: /* apply */ 4084 case OP_PAPPLY: /* apply */
3972 SCHEME_V->code = car (args); 4085 SCHEME_V->code = car (args);
3973 SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); 4086 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3974 /*SCHEME_V->args = cadr(args); */ 4087 /*SCHEME_V->args = cadr(args); */
… …
3988 } 4101 }
3989 4102
3990 if (USE_ERROR_CHECKING) abort (); 4103 if (USE_ERROR_CHECKING) abort ();
3991} 4104}
3992 4105
3993static int 4106/* math, cxr */
4107ecb_hot static int
3994opexe_1 (SCHEME_P_ enum scheme_opcodes op) 4108opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3995{ 4109{
3996 pointer args = SCHEME_V->args; 4110 pointer args = SCHEME_V->args;
3997 pointer x = car (args); 4111 pointer x = car (args);
3998 num v; 4112 num v;
… …
4011 Error_1 ("inexact->exact: not integral:", x); 4125 Error_1 ("inexact->exact: not integral:", x);
4012 } 4126 }
4013 4127
4014 s_return (x); 4128 s_return (x);
4015 4129
4130 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4131 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4132 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4133 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4134
4135 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)))); 4136 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)) 4137 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4018 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args)))))); 4138 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4019 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4139 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4020 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4140 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
… …
4026 s_return (mk_real (SCHEME_A_ 4146 s_return (mk_real (SCHEME_A_
4027 cdr (args) == NIL 4147 cdr (args) == NIL
4028 ? atan (rvalue (x)) 4148 ? atan (rvalue (x))
4029 : atan2 (rvalue (x), rvalue (cadr (args))))); 4149 : atan2 (rvalue (x), rvalue (cadr (args)))));
4030 4150
4031 case OP_SQRT:
4032 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4033
4034 case OP_EXPT: 4151 case OP_EXPT:
4035 { 4152 {
4036 RVALUE result; 4153 RVALUE result;
4037 int real_result = 1; 4154 int real_result = 1;
4038 pointer y = cadr (args); 4155 pointer y = cadr (args);
… …
4060 if (real_result) 4177 if (real_result)
4061 s_return (mk_real (SCHEME_A_ result)); 4178 s_return (mk_real (SCHEME_A_ result));
4062 else 4179 else
4063 s_return (mk_integer (SCHEME_A_ result)); 4180 s_return (mk_integer (SCHEME_A_ result));
4064 } 4181 }
4065
4066 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4067 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4068 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4069 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4070#endif 4182#endif
4071 4183
4072 case OP_ADD: /* + */ 4184 case OP_ADD: /* + */
4073 v = num_zero; 4185 v = num_zero;
4074 4186
… …
4376 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4488 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4377 4489
4378 s_return (newstr); 4490 s_return (newstr);
4379 } 4491 }
4380 4492
4381 case OP_SUBSTR: /* substring */ 4493 case OP_STRING_COPY: /* substring/string-copy */
4382 { 4494 {
4383 char *str = strvalue (x); 4495 char *str = strvalue (x);
4384 int index0 = ivalue_unchecked (cadr (args)); 4496 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4385 int index1; 4497 int index1;
4386 int len; 4498 int len;
4387 4499
4388 if (index0 > strlength (x)) 4500 if (index0 > strlength (x))
4389 Error_1 ("substring: start out of bounds:", cadr (args)); 4501 Error_1 ("string->copy: start out of bounds:", cadr (args));
4390 4502
4391 if (cddr (args) != NIL) 4503 if (cddr (args) != NIL)
4392 { 4504 {
4393 index1 = ivalue_unchecked (caddr (args)); 4505 index1 = ivalue_unchecked (caddr (args));
4394 4506
4395 if (index1 > strlength (x) || index1 < index0) 4507 if (index1 > strlength (x) || index1 < index0)
4396 Error_1 ("substring: end out of bounds:", caddr (args)); 4508 Error_1 ("string->copy: end out of bounds:", caddr (args));
4397 } 4509 }
4398 else 4510 else
4399 index1 = strlength (x); 4511 index1 = strlength (x);
4400 4512
4401 len = index1 - index0; 4513 len = index1 - index0;
4402 x = mk_empty_string (SCHEME_A_ len, ' '); 4514 x = mk_counted_string (SCHEME_A_ str + index0, len);
4403 memcpy (strvalue (x), str + index0, len);
4404 strvalue (x)[len] = 0;
4405 4515
4406 s_return (x); 4516 s_return (x);
4407 } 4517 }
4408 4518
4409 case OP_VECTOR: /* vector */ 4519 case OP_VECTOR: /* vector */
… …
4483 } 4593 }
4484 4594
4485 if (USE_ERROR_CHECKING) abort (); 4595 if (USE_ERROR_CHECKING) abort ();
4486} 4596}
4487 4597
4488static int 4598/* relational ops */
4599ecb_hot static int
4489opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4600opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4490{ 4601{
4491 pointer x = SCHEME_V->args; 4602 pointer x = SCHEME_V->args;
4492 4603
4493 for (;;) 4604 for (;;)
… …
4514 } 4625 }
4515 4626
4516 s_return (S_T); 4627 s_return (S_T);
4517} 4628}
4518 4629
4519static int 4630/* predicates */
4631ecb_hot static int
4520opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4632opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4521{ 4633{
4522 pointer args = SCHEME_V->args; 4634 pointer args = SCHEME_V->args;
4523 pointer a = car (args); 4635 pointer a = car (args);
4524 pointer d = cdr (args); 4636 pointer d = cdr (args);
… …
4571 } 4683 }
4572 4684
4573 s_retbool (r); 4685 s_retbool (r);
4574} 4686}
4575 4687
4576static int 4688/* promises, list ops, ports */
4689ecb_hot static int
4577opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4690opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4578{ 4691{
4579 pointer args = SCHEME_V->args; 4692 pointer args = SCHEME_V->args;
4580 pointer a = car (args); 4693 pointer a = car (args);
4581 pointer x, y; 4694 pointer x, y;
… …
4598 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4711 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4599 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); 4712 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4600 s_return (SCHEME_V->value); 4713 s_return (SCHEME_V->value);
4601 4714
4602#if USE_PORTS 4715#if USE_PORTS
4716
4717 case OP_EOF_OBJECT: /* eof-object */
4718 s_return (S_EOF);
4603 4719
4604 case OP_WRITE: /* write */ 4720 case OP_WRITE: /* write */
4605 case OP_DISPLAY: /* display */ 4721 case OP_DISPLAY: /* display */
4606 case OP_WRITE_CHAR: /* write-char */ 4722 case OP_WRITE_CHAR: /* write-char */
4607 if (is_pair (cdr (SCHEME_V->args))) 4723 if (is_pair (cdr (SCHEME_V->args)))
… …
4621 else 4737 else
4622 SCHEME_V->print_flag = 0; 4738 SCHEME_V->print_flag = 0;
4623 4739
4624 s_goto (OP_P0LIST); 4740 s_goto (OP_P0LIST);
4625 4741
4742 //TODO: move to scheme
4626 case OP_NEWLINE: /* newline */ 4743 case OP_NEWLINE: /* newline */
4627 if (is_pair (args)) 4744 if (is_pair (args))
4628 { 4745 {
4629 if (a != SCHEME_V->outport) 4746 if (a != SCHEME_V->outport)
4630 { 4747 {
… …
4632 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4749 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4633 SCHEME_V->outport = a; 4750 SCHEME_V->outport = a;
4634 } 4751 }
4635 } 4752 }
4636 4753
4637 putstr (SCHEME_A_ "\n"); 4754 putcharacter (SCHEME_A_ '\n');
4638 s_return (S_T); 4755 s_return (S_T);
4639#endif 4756#endif
4640 4757
4641 case OP_ERR0: /* error */ 4758 case OP_ERR0: /* error */
4642 SCHEME_V->retcode = -1; 4759 SCHEME_V->retcode = -1;
… …
4651 putstr (SCHEME_A_ strvalue (car (args))); 4768 putstr (SCHEME_A_ strvalue (car (args)));
4652 SCHEME_V->args = cdr (args); 4769 SCHEME_V->args = cdr (args);
4653 s_goto (OP_ERR1); 4770 s_goto (OP_ERR1);
4654 4771
4655 case OP_ERR1: /* error */ 4772 case OP_ERR1: /* error */
4656 putstr (SCHEME_A_ " "); 4773 putcharacter (SCHEME_A_ ' ');
4657 4774
4658 if (args != NIL) 4775 if (args != NIL)
4659 { 4776 {
4660 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); 4777 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4661 SCHEME_V->args = a; 4778 SCHEME_V->args = a;
4662 SCHEME_V->print_flag = 1; 4779 SCHEME_V->print_flag = 1;
4663 s_goto (OP_P0LIST); 4780 s_goto (OP_P0LIST);
4664 } 4781 }
4665 else 4782 else
4666 { 4783 {
4667 putstr (SCHEME_A_ "\n"); 4784 putcharacter (SCHEME_A_ '\n');
4668 4785
4669 if (SCHEME_V->interactive_repl) 4786 if (SCHEME_V->interactive_repl)
4670 s_goto (OP_T0LVL); 4787 s_goto (OP_T0LVL);
4671 else 4788 else
4672 return -1; 4789 return -1;
… …
4880 } 4997 }
4881 4998
4882 if (USE_ERROR_CHECKING) abort (); 4999 if (USE_ERROR_CHECKING) abort ();
4883} 5000}
4884 5001
4885static int 5002/* reading */
5003ecb_cold static int
4886opexe_5 (SCHEME_P_ enum scheme_opcodes op) 5004opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4887{ 5005{
4888 pointer args = SCHEME_V->args; 5006 pointer args = SCHEME_V->args;
4889 pointer x; 5007 pointer x;
4890 5008
… …
5159 pointer b = cdr (args); 5277 pointer b = cdr (args);
5160 int ok_abbr = ok_abbrev (b); 5278 int ok_abbr = ok_abbrev (b);
5161 SCHEME_V->args = car (b); 5279 SCHEME_V->args = car (b);
5162 5280
5163 if (a == SCHEME_V->QUOTE && ok_abbr) 5281 if (a == SCHEME_V->QUOTE && ok_abbr)
5164 putstr (SCHEME_A_ "'"); 5282 putcharacter (SCHEME_A_ '\'');
5165 else if (a == SCHEME_V->QQUOTE && ok_abbr) 5283 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5166 putstr (SCHEME_A_ "`"); 5284 putcharacter (SCHEME_A_ '`');
5167 else if (a == SCHEME_V->UNQUOTE && ok_abbr) 5285 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5168 putstr (SCHEME_A_ ","); 5286 putcharacter (SCHEME_A_ ',');
5169 else if (a == SCHEME_V->UNQUOTESP && ok_abbr) 5287 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5170 putstr (SCHEME_A_ ",@"); 5288 putstr (SCHEME_A_ ",@");
5171 else 5289 else
5172 { 5290 {
5173 putstr (SCHEME_A_ "("); 5291 putcharacter (SCHEME_A_ '(');
5174 s_save (SCHEME_A_ OP_P1LIST, b, NIL); 5292 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5175 SCHEME_V->args = a; 5293 SCHEME_V->args = a;
5176 } 5294 }
5177 5295
5178 s_goto (OP_P0LIST); 5296 s_goto (OP_P0LIST);
… …
5180 5298
5181 case OP_P1LIST: 5299 case OP_P1LIST:
5182 if (is_pair (args)) 5300 if (is_pair (args))
5183 { 5301 {
5184 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); 5302 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5185 putstr (SCHEME_A_ " "); 5303 putcharacter (SCHEME_A_ ' ');
5186 SCHEME_V->args = car (args); 5304 SCHEME_V->args = car (args);
5187 s_goto (OP_P0LIST); 5305 s_goto (OP_P0LIST);
5188 } 5306 }
5189 else if (is_vector (args)) 5307 else if (is_vector (args))
5190 { 5308 {
… …
5198 { 5316 {
5199 putstr (SCHEME_A_ " . "); 5317 putstr (SCHEME_A_ " . ");
5200 printatom (SCHEME_A_ args, SCHEME_V->print_flag); 5318 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5201 } 5319 }
5202 5320
5203 putstr (SCHEME_A_ ")"); 5321 putcharacter (SCHEME_A_ ')');
5204 s_return (S_T); 5322 s_return (S_T);
5205 } 5323 }
5206 5324
5207 case OP_PVECFROM: 5325 case OP_PVECFROM:
5208 { 5326 {
… …
5210 pointer vec = car (args); 5328 pointer vec = car (args);
5211 int len = veclength (vec); 5329 int len = veclength (vec);
5212 5330
5213 if (i == len) 5331 if (i == len)
5214 { 5332 {
5215 putstr (SCHEME_A_ ")"); 5333 putcharacter (SCHEME_A_ ')');
5216 s_return (S_T); 5334 s_return (S_T);
5217 } 5335 }
5218 else 5336 else
5219 { 5337 {
5220 pointer elem = vector_get (vec, i); 5338 pointer elem = vector_get (vec, i);
… …
5222 ivalue_unchecked (cdr (args)) = i + 1; 5340 ivalue_unchecked (cdr (args)) = i + 1;
5223 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5341 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5224 SCHEME_V->args = elem; 5342 SCHEME_V->args = elem;
5225 5343
5226 if (i > 0) 5344 if (i > 0)
5227 putstr (SCHEME_A_ " "); 5345 putcharacter (SCHEME_A_ ' ');
5228 5346
5229 s_goto (OP_P0LIST); 5347 s_goto (OP_P0LIST);
5230 } 5348 }
5231 } 5349 }
5232 } 5350 }
5233 5351
5234 if (USE_ERROR_CHECKING) abort (); 5352 if (USE_ERROR_CHECKING) abort ();
5235} 5353}
5236 5354
5237static int 5355/* list ops */
5356ecb_hot static int
5238opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5357opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5239{ 5358{
5240 pointer args = SCHEME_V->args; 5359 pointer args = SCHEME_V->args;
5241 pointer a = car (args); 5360 pointer a = car (args);
5242 pointer x, y; 5361 pointer x, y;
… …
5300 5419
5301/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5420/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5302typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); 5421typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5303 5422
5304typedef int (*test_predicate)(pointer); 5423typedef int (*test_predicate)(pointer);
5305static int 5424
5425ecb_hot static int
5306tst_any (pointer p) 5426tst_any (pointer p)
5307{ 5427{
5308 return 1; 5428 return 1;
5309} 5429}
5310 5430
5311static int 5431ecb_hot static int
5312tst_inonneg (pointer p) 5432tst_inonneg (pointer p)
5313{ 5433{
5314 return is_integer (p) && ivalue_unchecked (p) >= 0; 5434 return is_integer (p) && ivalue_unchecked (p) >= 0;
5315} 5435}
5316 5436
5317static int 5437ecb_hot static int
5318tst_is_list (SCHEME_P_ pointer p) 5438tst_is_list (SCHEME_P_ pointer p)
5319{ 5439{
5320 return p == NIL || is_pair (p); 5440 return p == NIL || is_pair (p);
5321} 5441}
5322 5442
… …
5365#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" 5485#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5366#include "opdefines.h" 5486#include "opdefines.h"
5367#undef OP_DEF 5487#undef OP_DEF
5368; 5488;
5369 5489
5370static const char * 5490ecb_cold static const char *
5371opname (int idx) 5491opname (int idx)
5372{ 5492{
5373 const char *name = opnames; 5493 const char *name = opnames;
5374 5494
5375 /* should do this at compile time, but would require external program, right? */ 5495 /* should do this at compile time, but would require external program, right? */
… …
5377 name += strlen (name) + 1; 5497 name += strlen (name) + 1;
5378 5498
5379 return *name ? name : "ILLEGAL"; 5499 return *name ? name : "ILLEGAL";
5380} 5500}
5381 5501
5382static const char * 5502ecb_cold static const char *
5383procname (pointer x) 5503procname (pointer x)
5384{ 5504{
5385 return opname (procnum (x)); 5505 return opname (procnum (x));
5386} 5506}
5387 5507
… …
5407#undef OP_DEF 5527#undef OP_DEF
5408 {0} 5528 {0}
5409}; 5529};
5410 5530
5411/* kernel of this interpreter */ 5531/* kernel of this interpreter */
5412static void ecb_hot 5532ecb_hot static void
5413Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5533Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5414{ 5534{
5415 SCHEME_V->op = op; 5535 SCHEME_V->op = op;
5416 5536
5417 for (;;) 5537 for (;;)
… …
5508 } 5628 }
5509} 5629}
5510 5630
5511/* ========== Initialization of internal keywords ========== */ 5631/* ========== Initialization of internal keywords ========== */
5512 5632
5513static void 5633ecb_cold static void
5514assign_syntax (SCHEME_P_ const char *name) 5634assign_syntax (SCHEME_P_ const char *name)
5515{ 5635{
5516 pointer x = oblist_add_by_name (SCHEME_A_ name); 5636 pointer x = oblist_add_by_name (SCHEME_A_ name);
5517 set_typeflag (x, typeflag (x) | T_SYNTAX); 5637 set_typeflag (x, typeflag (x) | T_SYNTAX);
5518} 5638}
5519 5639
5520static void 5640ecb_cold static void
5521assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5641assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5522{ 5642{
5523 pointer x = mk_symbol (SCHEME_A_ name); 5643 pointer x = mk_symbol (SCHEME_A_ name);
5524 pointer y = mk_proc (SCHEME_A_ op); 5644 pointer y = mk_proc (SCHEME_A_ op);
5525 new_slot_in_env (SCHEME_A_ x, y); 5645 new_slot_in_env (SCHEME_A_ x, y);
… …
5533 ivalue_unchecked (y) = op; 5653 ivalue_unchecked (y) = op;
5534 return y; 5654 return y;
5535} 5655}
5536 5656
5537/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5657/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5538static int 5658ecb_hot static int
5539syntaxnum (pointer p) 5659syntaxnum (pointer p)
5540{ 5660{
5541 const char *s = strvalue (p); 5661 const char *s = strvalue (p);
5542 5662
5543 switch (strlength (p)) 5663 switch (strlength (p))
… …
5660#endif 5780#endif
5661 } 5781 }
5662 5782
5663 SCHEME_V->gc_verbose = 0; 5783 SCHEME_V->gc_verbose = 0;
5664 dump_stack_initialize (SCHEME_A); 5784 dump_stack_initialize (SCHEME_A);
5665 SCHEME_V->code = NIL; 5785 SCHEME_V->code = NIL;
5666 SCHEME_V->args = NIL; 5786 SCHEME_V->args = NIL;
5667 SCHEME_V->envir = NIL; 5787 SCHEME_V->envir = NIL;
5788 SCHEME_V->value = NIL;
5668 SCHEME_V->tracing = 0; 5789 SCHEME_V->tracing = 0;
5669 5790
5670 /* init NIL */ 5791 /* init NIL */
5671 set_typeflag (NIL, T_ATOM | T_MARK); 5792 set_typeflag (NIL, T_ATOM | T_MARK);
5672 set_car (NIL, NIL); 5793 set_car (NIL, NIL);
… …
5728 5849
5729 return !SCHEME_V->no_memory; 5850 return !SCHEME_V->no_memory;
5730} 5851}
5731 5852
5732#if USE_PORTS 5853#if USE_PORTS
5733void 5854ecb_cold void
5734scheme_set_input_port_file (SCHEME_P_ int fin) 5855scheme_set_input_port_file (SCHEME_P_ int fin)
5735{ 5856{
5736 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 5857 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5737} 5858}
5738 5859
5739void 5860ecb_cold void
5740scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 5861scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5741{ 5862{
5742 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 5863 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5743} 5864}
5744 5865
5745void 5866ecb_cold void
5746scheme_set_output_port_file (SCHEME_P_ int fout) 5867scheme_set_output_port_file (SCHEME_P_ int fout)
5747{ 5868{
5748 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 5869 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5749} 5870}
5750 5871
5751void 5872ecb_cold void
5752scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 5873scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5753{ 5874{
5754 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 5875 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5755} 5876}
5756#endif 5877#endif
5757 5878
5758void 5879ecb_cold void
5759scheme_set_external_data (SCHEME_P_ void *p) 5880scheme_set_external_data (SCHEME_P_ void *p)
5760{ 5881{
5761 SCHEME_V->ext_data = p; 5882 SCHEME_V->ext_data = p;
5762} 5883}
5763 5884
… …
5795 SCHEME_V->loadport = NIL; 5916 SCHEME_V->loadport = NIL;
5796 SCHEME_V->gc_verbose = 0; 5917 SCHEME_V->gc_verbose = 0;
5797 gc (SCHEME_A_ NIL, NIL); 5918 gc (SCHEME_A_ NIL, NIL);
5798 5919
5799 for (i = 0; i <= SCHEME_V->last_cell_seg; i++) 5920 for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5800 free (SCHEME_V->alloc_seg[i]); 5921 free (SCHEME_V->cell_seg[i]);
5801 5922
5802#if SHOW_ERROR_LINE 5923#if SHOW_ERROR_LINE
5803 for (i = 0; i <= SCHEME_V->file_i; i++) 5924 for (i = 0; i <= SCHEME_V->file_i; i++)
5804 { 5925 {
5805 if (SCHEME_V->load_stack[i].kind & port_file) 5926 if (SCHEME_V->load_stack[i].kind & port_file)
… …
5811 } 5932 }
5812 } 5933 }
5813#endif 5934#endif
5814} 5935}
5815 5936
5816void 5937ecb_cold void
5817scheme_load_file (SCHEME_P_ int fin) 5938scheme_load_file (SCHEME_P_ int fin)
5818{ 5939{
5819 scheme_load_named_file (SCHEME_A_ fin, 0); 5940 scheme_load_named_file (SCHEME_A_ fin, 0);
5820} 5941}
5821 5942
5822void 5943ecb_cold void
5823scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 5944scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5824{ 5945{
5825 dump_stack_reset (SCHEME_A); 5946 dump_stack_reset (SCHEME_A);
5826 SCHEME_V->envir = SCHEME_V->global_env; 5947 SCHEME_V->envir = SCHEME_V->global_env;
5827 SCHEME_V->file_i = 0; 5948 SCHEME_V->file_i = 0;
5828 SCHEME_V->load_stack[0].unget = -1; 5949 SCHEME_V->load_stack[0].unget = -1;
5829 SCHEME_V->load_stack[0].kind = port_input | port_file; 5950 SCHEME_V->load_stack[0].kind = port_input | port_file;
5830 SCHEME_V->load_stack[0].rep.stdio.file = fin; 5951 SCHEME_V->load_stack[0].rep.stdio.file = fin;
5831#if USE_PORTS
5832 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 5952 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5833#endif
5834 SCHEME_V->retcode = 0; 5953 SCHEME_V->retcode = 0;
5835 5954
5836#if USE_PORTS
5837 if (fin == STDIN_FILENO) 5955 if (fin == STDIN_FILENO)
5838 SCHEME_V->interactive_repl = 1; 5956 SCHEME_V->interactive_repl = 1;
5839#endif
5840 5957
5841#if USE_PORTS 5958#if USE_PORTS
5842#if SHOW_ERROR_LINE 5959#if SHOW_ERROR_LINE
5843 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0; 5960 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5844 5961
… …
5848#endif 5965#endif
5849 5966
5850 SCHEME_V->inport = SCHEME_V->loadport; 5967 SCHEME_V->inport = SCHEME_V->loadport;
5851 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 5968 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5852 Eval_Cycle (SCHEME_A_ OP_T0LVL); 5969 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5970
5853 set_typeflag (SCHEME_V->loadport, T_ATOM); 5971 set_typeflag (SCHEME_V->loadport, T_ATOM);
5854 5972
5855 if (SCHEME_V->retcode == 0) 5973 if (SCHEME_V->retcode == 0)
5856 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5974 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5857} 5975}
5858 5976
5859void 5977ecb_cold void
5860scheme_load_string (SCHEME_P_ const char *cmd) 5978scheme_load_string (SCHEME_P_ const char *cmd)
5861{ 5979{
5980#if USE_PORTs
5862 dump_stack_reset (SCHEME_A); 5981 dump_stack_reset (SCHEME_A);
5863 SCHEME_V->envir = SCHEME_V->global_env; 5982 SCHEME_V->envir = SCHEME_V->global_env;
5864 SCHEME_V->file_i = 0; 5983 SCHEME_V->file_i = 0;
5865 SCHEME_V->load_stack[0].kind = port_input | port_string; 5984 SCHEME_V->load_stack[0].kind = port_input | port_string;
5866 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ 5985 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5867 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); 5986 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5868 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; 5987 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5869#if USE_PORTS
5870 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 5988 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5871#endif
5872 SCHEME_V->retcode = 0; 5989 SCHEME_V->retcode = 0;
5873 SCHEME_V->interactive_repl = 0; 5990 SCHEME_V->interactive_repl = 0;
5874 SCHEME_V->inport = SCHEME_V->loadport; 5991 SCHEME_V->inport = SCHEME_V->loadport;
5875 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 5992 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5876 Eval_Cycle (SCHEME_A_ OP_T0LVL); 5993 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5877 set_typeflag (SCHEME_V->loadport, T_ATOM); 5994 set_typeflag (SCHEME_V->loadport, T_ATOM);
5878 5995
5879 if (SCHEME_V->retcode == 0) 5996 if (SCHEME_V->retcode == 0)
5880 SCHEME_V->retcode = SCHEME_V->nesting != 0; 5997 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5998#else
5999 abort ();
6000#endif
5881} 6001}
5882 6002
5883void 6003ecb_cold void
5884scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 6004scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5885{ 6005{
5886 pointer x; 6006 pointer x;
5887 6007
5888 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 6008 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5893 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 6013 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5894} 6014}
5895 6015
5896#if !STANDALONE 6016#if !STANDALONE
5897 6017
5898void 6018ecb_cold void
5899scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 6019scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5900{ 6020{
5901 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 6021 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5902} 6022}
5903 6023
5904void 6024ecb_cold void
5905scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 6025scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5906{ 6026{
5907 int i; 6027 int i;
5908 6028
5909 for (i = 0; i < count; i++) 6029 for (i = 0; i < count; i++)
5910 scheme_register_foreign_func (SCHEME_A_ list + i); 6030 scheme_register_foreign_func (SCHEME_A_ list + i);
5911} 6031}
5912 6032
5913pointer 6033ecb_cold pointer
5914scheme_apply0 (SCHEME_P_ const char *procname) 6034scheme_apply0 (SCHEME_P_ const char *procname)
5915{ 6035{
5916 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 6036 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5917} 6037}
5918 6038
5919void 6039ecb_cold void
5920save_from_C_call (SCHEME_P) 6040save_from_C_call (SCHEME_P)
5921{ 6041{
5922 pointer saved_data = cons (car (S_SINK), 6042 pointer saved_data = cons (car (S_SINK),
5923 cons (SCHEME_V->envir, 6043 cons (SCHEME_V->envir,
5924 SCHEME_V->dump)); 6044 SCHEME_V->dump));
… …
5928 /* Truncate the dump stack so TS will return here when done, not 6048 /* Truncate the dump stack so TS will return here when done, not
5929 directly resume pre-C-call operations. */ 6049 directly resume pre-C-call operations. */
5930 dump_stack_reset (SCHEME_A); 6050 dump_stack_reset (SCHEME_A);
5931} 6051}
5932 6052
5933void 6053ecb_cold void
5934restore_from_C_call (SCHEME_P) 6054restore_from_C_call (SCHEME_P)
5935{ 6055{
5936 set_car (S_SINK, caar (SCHEME_V->c_nest)); 6056 set_car (S_SINK, caar (SCHEME_V->c_nest));
5937 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 6057 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5938 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 6058 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5939 /* Pop */ 6059 /* Pop */
5940 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 6060 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5941} 6061}
5942 6062
5943/* "func" and "args" are assumed to be already eval'ed. */ 6063/* "func" and "args" are assumed to be already eval'ed. */
5944pointer 6064ecb_cold pointer
5945scheme_call (SCHEME_P_ pointer func, pointer args) 6065scheme_call (SCHEME_P_ pointer func, pointer args)
5946{ 6066{
5947 int old_repl = SCHEME_V->interactive_repl; 6067 int old_repl = SCHEME_V->interactive_repl;
5948 6068
5949 SCHEME_V->interactive_repl = 0; 6069 SCHEME_V->interactive_repl = 0;
… …
5956 SCHEME_V->interactive_repl = old_repl; 6076 SCHEME_V->interactive_repl = old_repl;
5957 restore_from_C_call (SCHEME_A); 6077 restore_from_C_call (SCHEME_A);
5958 return SCHEME_V->value; 6078 return SCHEME_V->value;
5959} 6079}
5960 6080
5961pointer 6081ecb_cold pointer
5962scheme_eval (SCHEME_P_ pointer obj) 6082scheme_eval (SCHEME_P_ pointer obj)
5963{ 6083{
5964 int old_repl = SCHEME_V->interactive_repl; 6084 int old_repl = SCHEME_V->interactive_repl;
5965 6085
5966 SCHEME_V->interactive_repl = 0; 6086 SCHEME_V->interactive_repl = 0;
… …
5978 6098
5979/* ========== Main ========== */ 6099/* ========== Main ========== */
5980 6100
5981#if STANDALONE 6101#if STANDALONE
5982 6102
5983int 6103ecb_cold int
5984main (int argc, char **argv) 6104main (int argc, char **argv)
5985{ 6105{
5986# if USE_MULTIPLICITY 6106# if USE_MULTIPLICITY
5987 scheme ssc; 6107 scheme ssc;
5988 scheme *const SCHEME_V = &ssc; 6108 scheme *const SCHEME_V = &ssc;
… …
6029 } 6149 }
6030#endif 6150#endif
6031 6151
6032 do 6152 do
6033 { 6153 {
6034#if USE_PORTS
6035 if (strcmp (file_name, "-") == 0) 6154 if (strcmp (file_name, "-") == 0)
6036 fin = STDIN_FILENO; 6155 fin = STDIN_FILENO;
6037 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) 6156 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
6038 { 6157 {
6039 pointer args = NIL; 6158 pointer args = NIL;
… …
6057 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args); 6176 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
6058 6177
6059 } 6178 }
6060 else 6179 else
6061 fin = open (file_name, O_RDONLY); 6180 fin = open (file_name, O_RDONLY);
6062#endif
6063 6181
6064 if (isfile && fin < 0) 6182 if (isfile && fin < 0)
6065 { 6183 {
6066 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); 6184 putstr (SCHEME_A_ "Could not open file ");
6185 putstr (SCHEME_A_ file_name);
6186 putcharacter (SCHEME_A_ '\n');
6067 } 6187 }
6068 else 6188 else
6069 { 6189 {
6070 if (isfile) 6190 if (isfile)
6071 scheme_load_named_file (SCHEME_A_ fin, file_name); 6191 scheme_load_named_file (SCHEME_A_ fin, file_name);
6072 else 6192 else
6073 scheme_load_string (SCHEME_A_ file_name); 6193 scheme_load_string (SCHEME_A_ file_name);
6074 6194
6075#if USE_PORTS
6076 if (!isfile || fin != STDIN_FILENO) 6195 if (!isfile || fin != STDIN_FILENO)
6077 { 6196 {
6078 if (SCHEME_V->retcode != 0) 6197 if (SCHEME_V->retcode != 0)
6079 { 6198 {
6080 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); 6199 putstr (SCHEME_A_ "Errors encountered reading ");
6200 putstr (SCHEME_A_ file_name);
6201 putcharacter (SCHEME_A_ '\n');
6081 } 6202 }
6082 6203
6083 if (isfile) 6204 if (isfile)
6084 close (fin); 6205 close (fin);
6085 } 6206 }
6086#endif
6087 } 6207 }
6088 6208
6089 file_name = *argv++; 6209 file_name = *argv++;
6090 } 6210 }
6091 while (file_name != 0); 6211 while (file_name != 0);

Diff Legend

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