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.57 by root, Tue Dec 1 04:57:49 2015 UTC vs.
Revision 1.64 by root, Wed Dec 2 17:01:18 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>
32#endif 30#endif
33#if USE_MATH 31#if USE_MATH
34# include <math.h> 32# include <math.h>
35#endif 33#endif
36 34
35#define ECB_NO_THREADS 1
37#include "ecb.h" 36#include "ecb.h"
38 37
39#include <sys/types.h> 38#include <sys/types.h>
40#include <sys/stat.h> 39#include <sys/stat.h>
41#include <fcntl.h> 40#include <fcntl.h>
… …
49#include <string.h> 48#include <string.h>
50 49
51#include <limits.h> 50#include <limits.h>
52#include <inttypes.h> 51#include <inttypes.h>
53#include <float.h> 52#include <float.h>
54//#include <ctype.h> 53
54#if !USE_SYSTEM_MALLOC
55# define PAGE_SIZE 4096 /* does not work on sparc/alpha */
56# include "malloc.c"
57# define malloc(n) tiny_malloc (n)
58# define realloc(p,n) tiny_realloc (p, n)
59# define free(p) tiny_free (p)
60#endif
55 61
56#if '1' != '0' + 1 \ 62#if '1' != '0' + 1 \
57 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \ 63 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
58 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \ 64 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
59 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \ 65 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
… …
91 97
92#if !USE_MULTIPLICITY 98#if !USE_MULTIPLICITY
93static scheme sc; 99static scheme sc;
94#endif 100#endif
95 101
96static void 102ecb_cold static void
97xbase (char *s, long n, int base) 103xbase (char *s, long n, int base)
98{ 104{
99 if (n < 0) 105 if (n < 0)
100 { 106 {
101 *s++ = '-'; 107 *s++ = '-';
… …
116 char x = *s; *s = *p; *p = x; 122 char x = *s; *s = *p; *p = x;
117 --p; ++s; 123 --p; ++s;
118 } 124 }
119} 125}
120 126
121static void 127ecb_cold static void
122xnum (char *s, long n) 128xnum (char *s, long n)
123{ 129{
124 xbase (s, n, 10); 130 xbase (s, n, 10);
125} 131}
126 132
127static void 133ecb_cold static void
128putnum (SCHEME_P_ long n) 134putnum (SCHEME_P_ long n)
129{ 135{
130 char buf[64]; 136 char buf[64];
131 137
132 xnum (buf, n); 138 xnum (buf, n);
133 putstr (SCHEME_A_ buf); 139 putstr (SCHEME_A_ buf);
134} 140}
141
142#if USE_CHAR_CLASSIFIERS
143#include <ctype.h>
144#else
135 145
136static char 146static char
137xtoupper (char c) 147xtoupper (char c)
138{ 148{
139 if (c >= 'a' && c <= 'z') 149 if (c >= 'a' && c <= 'z')
… …
159 169
160#define toupper(c) xtoupper (c) 170#define toupper(c) xtoupper (c)
161#define tolower(c) xtolower (c) 171#define tolower(c) xtolower (c)
162#define isdigit(c) xisdigit (c) 172#define isdigit(c) xisdigit (c)
163 173
174#endif
175
164#if USE_IGNORECASE 176#if USE_IGNORECASE
165static const char * 177ecb_cold static const char *
166xstrlwr (char *s) 178xstrlwr (char *s)
167{ 179{
168 const char *p = s; 180 const char *p = s;
169 181
170 while (*s) 182 while (*s)
… …
183# define stricmp(a,b) strcmp (a, b) 195# define stricmp(a,b) strcmp (a, b)
184# define strlwr(s) (s) 196# define strlwr(s) (s)
185#endif 197#endif
186 198
187#ifndef prompt 199#ifndef prompt
188# define prompt "ts> " 200# define prompt "ms> "
189#endif 201#endif
190 202
191#ifndef InitFile 203#ifndef InitFile
192# define InitFile "init.scm" 204# define InitFile "init.scm"
193#endif 205#endif
194 206
195enum scheme_types 207enum scheme_types
196{ 208{
197 T_INTEGER, 209 T_INTEGER,
210 T_CHARACTER,
198 T_REAL, 211 T_REAL,
199 T_STRING, 212 T_STRING,
200 T_SYMBOL, 213 T_SYMBOL,
201 T_PROC, 214 T_PROC,
202 T_PAIR, /* also used for free cells */ 215 T_PAIR, /* also used for free cells */
203 T_CLOSURE, 216 T_CLOSURE,
217 T_BYTECODE, // temp
218 T_MACRO,
204 T_CONTINUATION, 219 T_CONTINUATION,
205 T_FOREIGN, 220 T_FOREIGN,
206 T_CHARACTER,
207 T_PORT, 221 T_PORT,
208 T_VECTOR, 222 T_VECTOR,
209 T_MACRO,
210 T_PROMISE, 223 T_PROMISE,
211 T_ENVIRONMENT, 224 T_ENVIRONMENT,
212 /* one more... */ 225
213 T_NUM_SYSTEM_TYPES 226 T_NUM_SYSTEM_TYPES
214}; 227};
215 228
216#define T_MASKTYPE 0x000f 229#define T_MASKTYPE 0x000f
217#define T_SYNTAX 0x0010 230#define T_SYNTAX 0x0010
… …
371 384
372static pointer cadar (pointer p) { return car (cdr (car (p))); } 385static pointer cadar (pointer p) { return car (cdr (car (p))); }
373static pointer caddr (pointer p) { return car (cdr (cdr (p))); } 386static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
374static pointer cdaar (pointer p) { return cdr (car (car (p))); } 387static pointer cdaar (pointer p) { return cdr (car (car (p))); }
375 388
389static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); }
390
376INTERFACE void 391INTERFACE void
377set_car (pointer p, pointer q) 392set_car (pointer p, pointer q)
378{ 393{
379 CELL(p)->object.cons.car = CELL (q); 394 CELL(p)->object.cons.car = CELL (q);
380} 395}
… …
520 proper list: length 535 proper list: length
521 circular list: -1 536 circular list: -1
522 not even a pair: -2 537 not even a pair: -2
523 dotted list: -2 minus length before dot 538 dotted list: -2 minus length before dot
524*/ 539*/
525INTERFACE int 540ecb_hot INTERFACE int
526list_length (SCHEME_P_ pointer a) 541list_length (SCHEME_P_ pointer a)
527{ 542{
528 int i = 0; 543 int i = 0;
529 pointer slow, fast; 544 pointer slow, fast;
530 545
… …
569{ 584{
570 return list_length (SCHEME_A_ a) >= 0; 585 return list_length (SCHEME_A_ a) >= 0;
571} 586}
572 587
573#if USE_CHAR_CLASSIFIERS 588#if USE_CHAR_CLASSIFIERS
589
574ecb_inline int 590ecb_inline int
575Cisalpha (int c) 591Cisalpha (int c)
576{ 592{
577 return isascii (c) && isalpha (c); 593 return isascii (c) && isalpha (c);
578} 594}
… …
636 "gs", 652 "gs",
637 "rs", 653 "rs",
638 "us" 654 "us"
639}; 655};
640 656
641static int 657ecb_cold static int
642is_ascii_name (const char *name, int *pc) 658is_ascii_name (const char *name, int *pc)
643{ 659{
644 int i; 660 int i;
645 661
646 for (i = 0; i < 32; i++) 662 for (i = 0; i < 32; i++)
… …
668static int file_interactive (SCHEME_P); 684static int file_interactive (SCHEME_P);
669ecb_inline int is_one_of (const char *s, int c); 685ecb_inline int is_one_of (const char *s, int c);
670static int alloc_cellseg (SCHEME_P); 686static int alloc_cellseg (SCHEME_P);
671ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 687ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
672static void finalize_cell (SCHEME_P_ pointer a); 688static 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); 689static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
675static pointer mk_number (SCHEME_P_ const num n); 690static pointer mk_number (SCHEME_P_ const num n);
676static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 691static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
677static pointer mk_vector (SCHEME_P_ uint32_t len); 692static pointer mk_vector (SCHEME_P_ uint32_t len);
678static pointer mk_atom (SCHEME_P_ char *q); 693static pointer mk_atom (SCHEME_P_ char *q);
679static pointer mk_sharp_const (SCHEME_P_ char *name); 694static pointer mk_sharp_const (SCHEME_P_ char *name);
680 695
696static pointer mk_port (SCHEME_P_ port *p);
697
681#if USE_PORTS 698#if USE_PORTS
682static pointer mk_port (SCHEME_P_ port *p);
683static pointer port_from_filename (SCHEME_P_ const char *fn, int prop); 699static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
684static pointer port_from_file (SCHEME_P_ int, int prop); 700static pointer port_from_file (SCHEME_P_ int, int prop);
685static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 701static 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); 702static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop);
687static port *port_rep_from_file (SCHEME_P_ int, int prop); 703static 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); 704static 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); 705static void port_close (SCHEME_P_ pointer p, int flag);
690#endif 706#endif
707
691static void mark (pointer a); 708static void mark (pointer a);
692static void gc (SCHEME_P_ pointer a, pointer b); 709static void gc (SCHEME_P_ pointer a, pointer b);
693static int basic_inchar (port *pt); 710static int basic_inchar (port *pt);
694static int inchar (SCHEME_P); 711static int inchar (SCHEME_P);
695static void backchar (SCHEME_P_ int c); 712static void backchar (SCHEME_P_ int c);
696static char *readstr_upto (SCHEME_P_ int skip, const char *delim); 713static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
697static pointer readstrexp (SCHEME_P_ char delim); 714static pointer readstrexp (SCHEME_P_ char delim);
698ecb_inline int skipspace (SCHEME_P); 715static int skipspace (SCHEME_P);
699static int token (SCHEME_P); 716static int token (SCHEME_P);
700static void printslashstring (SCHEME_P_ char *s, int len); 717static void printslashstring (SCHEME_P_ char *s, int len);
701static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 718static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
702static void printatom (SCHEME_P_ pointer l, int f); 719static void printatom (SCHEME_P_ pointer l, int f);
703static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 720static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
883#endif 900#endif
884#endif 901#endif
885} 902}
886 903
887/* allocate new cell segment */ 904/* allocate new cell segment */
888static int 905ecb_cold static int
889alloc_cellseg (SCHEME_P) 906alloc_cellseg (SCHEME_P)
890{ 907{
891 struct cell *newp; 908 struct cell *newp;
892 struct cell *last; 909 struct cell *last;
893 struct cell *p; 910 struct cell *p;
… …
902 919
903 if (!cp && USE_ERROR_CHECKING) 920 if (!cp && USE_ERROR_CHECKING)
904 return k; 921 return k;
905 922
906 i = ++SCHEME_V->last_cell_seg; 923 i = ++SCHEME_V->last_cell_seg;
907 SCHEME_V->alloc_seg[i] = cp;
908 924
909 newp = (struct cell *)cp; 925 newp = (struct cell *)cp;
910 SCHEME_V->cell_seg[i] = newp; 926 SCHEME_V->cell_seg[i] = newp;
911 SCHEME_V->cell_segsize[i] = segsize; 927 SCHEME_V->cell_segsize[i] = segsize;
912 SCHEME_V->fcells += segsize; 928 SCHEME_V->fcells += segsize;
… …
935 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 951 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
936 return S_SINK; 952 return S_SINK;
937 953
938 if (SCHEME_V->free_cell == NIL) 954 if (SCHEME_V->free_cell == NIL)
939 { 955 {
940 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1; 956 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
941 957
942 gc (SCHEME_A_ a, b); 958 gc (SCHEME_A_ a, b);
943 959
944 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 960 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
945 { 961 {
… …
964 } 980 }
965} 981}
966 982
967/* To retain recent allocs before interpreter knows about them - 983/* To retain recent allocs before interpreter knows about them -
968 Tehom */ 984 Tehom */
969static void 985ecb_hot static void
970push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 986push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
971{ 987{
972 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 988 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
973 989
974 set_typeflag (holder, T_PAIR); 990 set_typeflag (holder, T_PAIR);
… …
976 set_car (holder, recent); 992 set_car (holder, recent);
977 set_cdr (holder, car (S_SINK)); 993 set_cdr (holder, car (S_SINK));
978 set_car (S_SINK, holder); 994 set_car (S_SINK, holder);
979} 995}
980 996
981static pointer 997ecb_hot static pointer
982get_cell (SCHEME_P_ pointer a, pointer b) 998get_cell (SCHEME_P_ pointer a, pointer b)
983{ 999{
984 pointer cell = get_cell_x (SCHEME_A_ a, b); 1000 pointer cell = get_cell_x (SCHEME_A_ a, b);
985 1001
986 /* For right now, include "a" and "b" in "cell" so that gc doesn't 1002 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1043#endif 1059#endif
1044 1060
1045/* Medium level cell allocation */ 1061/* Medium level cell allocation */
1046 1062
1047/* get new cons cell */ 1063/* get new cons cell */
1048pointer 1064ecb_hot static pointer
1049xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1065xcons (SCHEME_P_ pointer a, pointer b)
1050{ 1066{
1051 pointer x = get_cell (SCHEME_A_ a, b); 1067 pointer x = get_cell (SCHEME_A_ a, b);
1052 1068
1053 set_typeflag (x, T_PAIR); 1069 set_typeflag (x, T_PAIR);
1054
1055 if (immutable)
1056 setimmutable (x);
1057 1070
1058 set_car (x, a); 1071 set_car (x, a);
1059 set_cdr (x, b); 1072 set_cdr (x, b);
1060 1073
1061 return x; 1074 return x;
1062} 1075}
1063 1076
1064static pointer 1077ecb_hot static pointer
1078ximmutable_cons (SCHEME_P_ pointer a, pointer b)
1079{
1080 pointer x = xcons (SCHEME_A_ a, b);
1081 setimmutable (x);
1082 return x;
1083}
1084
1085#define cons(a,b) xcons (SCHEME_A_ a, b)
1086#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1087
1088ecb_cold static pointer
1065generate_symbol (SCHEME_P_ const char *name) 1089generate_symbol (SCHEME_P_ const char *name)
1066{ 1090{
1067 pointer x = mk_string (SCHEME_A_ name); 1091 pointer x = mk_string (SCHEME_A_ name);
1068 setimmutable (x); 1092 setimmutable (x);
1069 set_typeflag (x, T_SYMBOL | T_ATOM); 1093 set_typeflag (x, T_SYMBOL | T_ATOM);
… …
1075#ifndef USE_OBJECT_LIST 1099#ifndef USE_OBJECT_LIST
1076 1100
1077static int 1101static int
1078hash_fn (const char *key, int table_size) 1102hash_fn (const char *key, int table_size)
1079{ 1103{
1080 const unsigned char *p = key; 1104 const unsigned char *p = (unsigned char *)key;
1081 uint32_t hash = 2166136261; 1105 uint32_t hash = 2166136261U;
1082 1106
1083 while (*p) 1107 while (*p)
1084 hash = (hash ^ *p++) * 16777619; 1108 hash = (hash ^ *p++) * 16777619;
1085 1109
1086 return hash % table_size; 1110 return hash % table_size;
1087} 1111}
1088 1112
1089static pointer 1113ecb_cold static pointer
1090oblist_initial_value (SCHEME_P) 1114oblist_initial_value (SCHEME_P)
1091{ 1115{
1092 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1116 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1093} 1117}
1094 1118
1095/* returns the new symbol */ 1119/* returns the new symbol */
1096static pointer 1120ecb_cold static pointer
1097oblist_add_by_name (SCHEME_P_ const char *name) 1121oblist_add_by_name (SCHEME_P_ const char *name)
1098{ 1122{
1099 pointer x = generate_symbol (SCHEME_A_ name); 1123 pointer x = generate_symbol (SCHEME_A_ name);
1100 int location = hash_fn (name, veclength (SCHEME_V->oblist)); 1124 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))); 1125 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1102 return x; 1126 return x;
1103} 1127}
1104 1128
1105ecb_inline pointer 1129ecb_cold static pointer
1106oblist_find_by_name (SCHEME_P_ const char *name) 1130oblist_find_by_name (SCHEME_P_ const char *name)
1107{ 1131{
1108 int location; 1132 int location;
1109 pointer x; 1133 pointer x;
1110 char *s; 1134 char *s;
… …
1121 } 1145 }
1122 1146
1123 return NIL; 1147 return NIL;
1124} 1148}
1125 1149
1126static pointer 1150ecb_cold static pointer
1127oblist_all_symbols (SCHEME_P) 1151oblist_all_symbols (SCHEME_P)
1128{ 1152{
1129 int i; 1153 int i;
1130 pointer x; 1154 pointer x;
1131 pointer ob_list = NIL; 1155 pointer ob_list = NIL;
… …
1137 return ob_list; 1161 return ob_list;
1138} 1162}
1139 1163
1140#else 1164#else
1141 1165
1142static pointer 1166ecb_cold static pointer
1143oblist_initial_value (SCHEME_P) 1167oblist_initial_value (SCHEME_P)
1144{ 1168{
1145 return NIL; 1169 return NIL;
1146} 1170}
1147 1171
1148ecb_inline pointer 1172ecb_cold static pointer
1149oblist_find_by_name (SCHEME_P_ const char *name) 1173oblist_find_by_name (SCHEME_P_ const char *name)
1150{ 1174{
1151 pointer x; 1175 pointer x;
1152 char *s; 1176 char *s;
1153 1177
… …
1162 1186
1163 return NIL; 1187 return NIL;
1164} 1188}
1165 1189
1166/* returns the new symbol */ 1190/* returns the new symbol */
1167static pointer 1191ecb_cold static pointer
1168oblist_add_by_name (SCHEME_P_ const char *name) 1192oblist_add_by_name (SCHEME_P_ const char *name)
1169{ 1193{
1170 pointer x = generate_symbol (SCHEME_A_ name); 1194 pointer x = generate_symbol (SCHEME_A_ name);
1171 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1195 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1172 return x; 1196 return x;
1173} 1197}
1174 1198
1175static pointer 1199ecb_cold static pointer
1176oblist_all_symbols (SCHEME_P) 1200oblist_all_symbols (SCHEME_P)
1177{ 1201{
1178 return SCHEME_V->oblist; 1202 return SCHEME_V->oblist;
1179} 1203}
1180 1204
1181#endif 1205#endif
1182 1206
1183#if USE_PORTS
1184static pointer 1207ecb_cold static pointer
1185mk_port (SCHEME_P_ port *p) 1208mk_port (SCHEME_P_ port *p)
1186{ 1209{
1187 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1210 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1188 1211
1189 set_typeflag (x, T_PORT | T_ATOM); 1212 set_typeflag (x, T_PORT | T_ATOM);
1190 set_port (x, p); 1213 set_port (x, p);
1191 1214
1192 return x; 1215 return x;
1193} 1216}
1194#endif
1195 1217
1196pointer 1218ecb_cold pointer
1197mk_foreign_func (SCHEME_P_ foreign_func f) 1219mk_foreign_func (SCHEME_P_ foreign_func f)
1198{ 1220{
1199 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1221 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1200 1222
1201 set_typeflag (x, T_FOREIGN | T_ATOM); 1223 set_typeflag (x, T_FOREIGN | T_ATOM);
… …
1366 x = oblist_add_by_name (SCHEME_A_ name); 1388 x = oblist_add_by_name (SCHEME_A_ name);
1367 1389
1368 return x; 1390 return x;
1369} 1391}
1370 1392
1371INTERFACE pointer 1393ecb_cold INTERFACE pointer
1372gensym (SCHEME_P) 1394gensym (SCHEME_P)
1373{ 1395{
1374 pointer x; 1396 pointer x;
1375 char name[40] = "gensym-"; 1397 char name[40] = "gensym-";
1376 xnum (name + 7, ++SCHEME_V->gensym_cnt); 1398 xnum (name + 7, ++SCHEME_V->gensym_cnt);
… …
1383{ 1405{
1384 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; 1406 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1385} 1407}
1386 1408
1387/* make symbol or number atom from string */ 1409/* make symbol or number atom from string */
1388static pointer 1410ecb_cold static pointer
1389mk_atom (SCHEME_P_ char *q) 1411mk_atom (SCHEME_P_ char *q)
1390{ 1412{
1391 char c, *p; 1413 char c, *p;
1392 int has_dec_point = 0; 1414 int has_dec_point = 0;
1393 int has_fp_exp = 0; 1415 int has_fp_exp = 0;
… …
1464 1486
1465 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1487 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1466} 1488}
1467 1489
1468/* make constant */ 1490/* make constant */
1469static pointer 1491ecb_cold static pointer
1470mk_sharp_const (SCHEME_P_ char *name) 1492mk_sharp_const (SCHEME_P_ char *name)
1471{ 1493{
1472 if (!strcmp (name, "t")) 1494 if (!strcmp (name, "t"))
1473 return S_T; 1495 return S_T;
1474 else if (!strcmp (name, "f")) 1496 else if (!strcmp (name, "f"))
… …
1529 } 1551 }
1530} 1552}
1531 1553
1532/* ========== garbage collector ========== */ 1554/* ========== garbage collector ========== */
1533 1555
1556static void
1557finalize_cell (SCHEME_P_ pointer a)
1558{
1559 /* TODO, fast bitmap check? */
1560 if (is_string (a) || is_symbol (a))
1561 free (strvalue (a));
1562 else if (is_vector (a))
1563 free (vecvalue (a));
1564#if USE_PORTS
1565 else if (is_port (a))
1566 {
1567 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1568 port_close (SCHEME_A_ a, port_input | port_output);
1569
1570 free (port (a));
1571 }
1572#endif
1573}
1574
1534/*-- 1575/*--
1535 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1576 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1536 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1577 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1537 * for marking. 1578 * for marking.
1538 * 1579 *
1539 * The exception is vectors - vectors are currently marked recursively, 1580 * The exception is vectors - vectors are currently marked recursively,
1540 * which is inherited form tinyscheme and could be fixed by having another 1581 * which is inherited form tinyscheme and could be fixed by having another
1541 * word of context in the vector 1582 * word of context in the vector
1542 */ 1583 */
1543static void 1584ecb_hot static void
1544mark (pointer a) 1585mark (pointer a)
1545{ 1586{
1546 pointer t, q, p; 1587 pointer t, q, p;
1547 1588
1548 t = 0; 1589 t = 0;
… …
1605 p = q; 1646 p = q;
1606 goto E6; 1647 goto E6;
1607 } 1648 }
1608} 1649}
1609 1650
1610/* garbage collection. parameter a, b is marked. */ 1651ecb_hot static void
1611static void 1652gc_free (SCHEME_P)
1612gc (SCHEME_P_ pointer a, pointer b)
1613{ 1653{
1614 int i; 1654 int i;
1615
1616 if (SCHEME_V->gc_verbose)
1617 putstr (SCHEME_A_ "gc...");
1618
1619 /* mark system globals */
1620 mark (SCHEME_V->oblist);
1621 mark (SCHEME_V->global_env);
1622
1623 /* mark current registers */
1624 mark (SCHEME_V->args);
1625 mark (SCHEME_V->envir);
1626 mark (SCHEME_V->code);
1627 dump_stack_mark (SCHEME_A);
1628 mark (SCHEME_V->value);
1629 mark (SCHEME_V->inport);
1630 mark (SCHEME_V->save_inport);
1631 mark (SCHEME_V->outport);
1632 mark (SCHEME_V->loadport);
1633
1634 /* Mark recent objects the interpreter doesn't know about yet. */
1635 mark (car (S_SINK));
1636 /* Mark any older stuff above nested C calls */
1637 mark (SCHEME_V->c_nest);
1638
1639#if USE_INTCACHE
1640 /* mark intcache */
1641 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1642 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1643 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1644#endif
1645
1646 /* mark variables a, b */
1647 mark (a);
1648 mark (b);
1649
1650 /* garbage collect */
1651 clrmark (NIL);
1652 SCHEME_V->fcells = 0;
1653 SCHEME_V->free_cell = NIL;
1654
1655 if (SCHEME_V->gc_verbose)
1656 putstr (SCHEME_A_ "freeing...");
1657
1658 uint32_t total = 0; 1655 uint32_t total = 0;
1659 1656
1660 /* Here we scan the cells to build the free-list. */ 1657 /* Here we scan the cells to build the free-list. */
1661 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1658 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1662 { 1659 {
… …
1691 { 1688 {
1692 putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n"); 1689 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");
1693 } 1690 }
1694} 1691}
1695 1692
1696static void 1693/* garbage collection. parameter a, b is marked. */
1697finalize_cell (SCHEME_P_ pointer a) 1694ecb_cold static void
1695gc (SCHEME_P_ pointer a, pointer b)
1698{ 1696{
1699 /* TODO, fast bitmap check? */ 1697 int i;
1700 if (is_string (a) || is_symbol (a))
1701 free (strvalue (a));
1702 else if (is_vector (a))
1703 free (vecvalue (a));
1704#if USE_PORTS
1705 else if (is_port (a))
1706 {
1707 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1708 port_close (SCHEME_A_ a, port_input | port_output);
1709 1698
1710 free (port (a)); 1699 if (SCHEME_V->gc_verbose)
1711 } 1700 putstr (SCHEME_A_ "gc...");
1701
1702 /* mark system globals */
1703 mark (SCHEME_V->oblist);
1704 mark (SCHEME_V->global_env);
1705
1706 /* mark current registers */
1707 mark (SCHEME_V->args);
1708 mark (SCHEME_V->envir);
1709 mark (SCHEME_V->code);
1710 dump_stack_mark (SCHEME_A);
1711 mark (SCHEME_V->value);
1712 mark (SCHEME_V->inport);
1713 mark (SCHEME_V->save_inport);
1714 mark (SCHEME_V->outport);
1715 mark (SCHEME_V->loadport);
1716
1717 /* Mark recent objects the interpreter doesn't know about yet. */
1718 mark (car (S_SINK));
1719 /* Mark any older stuff above nested C calls */
1720 mark (SCHEME_V->c_nest);
1721
1722#if USE_INTCACHE
1723 /* mark intcache */
1724 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1725 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1726 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1712#endif 1727#endif
1728
1729 /* mark variables a, b */
1730 mark (a);
1731 mark (b);
1732
1733 /* garbage collect */
1734 clrmark (NIL);
1735 SCHEME_V->fcells = 0;
1736 SCHEME_V->free_cell = NIL;
1737
1738 if (SCHEME_V->gc_verbose)
1739 putstr (SCHEME_A_ "freeing...");
1740
1741 gc_free (SCHEME_A);
1713} 1742}
1714 1743
1715/* ========== Routines for Reading ========== */ 1744/* ========== Routines for Reading ========== */
1716 1745
1717static int 1746ecb_cold static int
1718file_push (SCHEME_P_ const char *fname) 1747file_push (SCHEME_P_ const char *fname)
1719{ 1748{
1720#if USE_PORTS
1721 int fin; 1749 int fin;
1722 1750
1723 if (SCHEME_V->file_i == MAXFIL - 1) 1751 if (SCHEME_V->file_i == MAXFIL - 1)
1724 return 0; 1752 return 0;
1725 1753
… …
1742 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0); 1770 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1743#endif 1771#endif
1744 } 1772 }
1745 1773
1746 return fin >= 0; 1774 return fin >= 0;
1747
1748#else
1749 return 1;
1750#endif
1751} 1775}
1752 1776
1753static void 1777ecb_cold static void
1754file_pop (SCHEME_P) 1778file_pop (SCHEME_P)
1755{ 1779{
1756 if (SCHEME_V->file_i != 0) 1780 if (SCHEME_V->file_i != 0)
1757 { 1781 {
1758 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1782 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
… …
1762 SCHEME_V->file_i--; 1786 SCHEME_V->file_i--;
1763 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i); 1787 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1764 } 1788 }
1765} 1789}
1766 1790
1767static int 1791ecb_cold static int
1768file_interactive (SCHEME_P) 1792file_interactive (SCHEME_P)
1769{ 1793{
1770#if USE_PORTS 1794#if USE_PORTS
1771 return SCHEME_V->file_i == 0 1795 return SCHEME_V->file_i == 0
1772 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1796 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
… …
1775 return 0; 1799 return 0;
1776#endif 1800#endif
1777} 1801}
1778 1802
1779#if USE_PORTS 1803#if USE_PORTS
1780static port * 1804ecb_cold static port *
1781port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1805port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1782{ 1806{
1783 int fd; 1807 int fd;
1784 int flags; 1808 int flags;
1785 char *rw; 1809 char *rw;
… …
1808# endif 1832# endif
1809 1833
1810 return pt; 1834 return pt;
1811} 1835}
1812 1836
1813static pointer 1837ecb_cold static pointer
1814port_from_filename (SCHEME_P_ const char *fn, int prop) 1838port_from_filename (SCHEME_P_ const char *fn, int prop)
1815{ 1839{
1816 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1840 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1817 1841
1818 if (!pt && USE_ERROR_CHECKING) 1842 if (!pt && USE_ERROR_CHECKING)
1819 return NIL; 1843 return NIL;
1820 1844
1821 return mk_port (SCHEME_A_ pt); 1845 return mk_port (SCHEME_A_ pt);
1822} 1846}
1823 1847
1824static port * 1848ecb_cold static port *
1825port_rep_from_file (SCHEME_P_ int f, int prop) 1849port_rep_from_file (SCHEME_P_ int f, int prop)
1826{ 1850{
1827 port *pt = malloc (sizeof *pt); 1851 port *pt = malloc (sizeof *pt);
1828 1852
1829 if (!pt && USE_ERROR_CHECKING) 1853 if (!pt && USE_ERROR_CHECKING)
… …
1834 pt->rep.stdio.file = f; 1858 pt->rep.stdio.file = f;
1835 pt->rep.stdio.closeit = 0; 1859 pt->rep.stdio.closeit = 0;
1836 return pt; 1860 return pt;
1837} 1861}
1838 1862
1839static pointer 1863ecb_cold static pointer
1840port_from_file (SCHEME_P_ int f, int prop) 1864port_from_file (SCHEME_P_ int f, int prop)
1841{ 1865{
1842 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1866 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1843 1867
1844 if (!pt && USE_ERROR_CHECKING) 1868 if (!pt && USE_ERROR_CHECKING)
1845 return NIL; 1869 return NIL;
1846 1870
1847 return mk_port (SCHEME_A_ pt); 1871 return mk_port (SCHEME_A_ pt);
1848} 1872}
1849 1873
1850static port * 1874ecb_cold static port *
1851port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1875port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1852{ 1876{
1853 port *pt = malloc (sizeof (port)); 1877 port *pt = malloc (sizeof (port));
1854 1878
1855 if (!pt && USE_ERROR_CHECKING) 1879 if (!pt && USE_ERROR_CHECKING)
… …
1861 pt->rep.string.curr = start; 1885 pt->rep.string.curr = start;
1862 pt->rep.string.past_the_end = past_the_end; 1886 pt->rep.string.past_the_end = past_the_end;
1863 return pt; 1887 return pt;
1864} 1888}
1865 1889
1866static pointer 1890ecb_cold static pointer
1867port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1891port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1868{ 1892{
1869 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1893 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1870 1894
1871 if (!pt && USE_ERROR_CHECKING) 1895 if (!pt && USE_ERROR_CHECKING)
… …
1874 return mk_port (SCHEME_A_ pt); 1898 return mk_port (SCHEME_A_ pt);
1875} 1899}
1876 1900
1877# define BLOCK_SIZE 256 1901# define BLOCK_SIZE 256
1878 1902
1879static port * 1903ecb_cold static port *
1880port_rep_from_scratch (SCHEME_P) 1904port_rep_from_scratch (SCHEME_P)
1881{ 1905{
1882 char *start; 1906 char *start;
1883 port *pt = malloc (sizeof (port)); 1907 port *pt = malloc (sizeof (port));
1884 1908
… …
1898 pt->rep.string.curr = start; 1922 pt->rep.string.curr = start;
1899 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1923 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1900 return pt; 1924 return pt;
1901} 1925}
1902 1926
1903static pointer 1927ecb_cold static pointer
1904port_from_scratch (SCHEME_P) 1928port_from_scratch (SCHEME_P)
1905{ 1929{
1906 port *pt = port_rep_from_scratch (SCHEME_A); 1930 port *pt = port_rep_from_scratch (SCHEME_A);
1907 1931
1908 if (!pt && USE_ERROR_CHECKING) 1932 if (!pt && USE_ERROR_CHECKING)
1909 return NIL; 1933 return NIL;
1910 1934
1911 return mk_port (SCHEME_A_ pt); 1935 return mk_port (SCHEME_A_ pt);
1912} 1936}
1913 1937
1914static void 1938ecb_cold static void
1915port_close (SCHEME_P_ pointer p, int flag) 1939port_close (SCHEME_P_ pointer p, int flag)
1916{ 1940{
1917 port *pt = port (p); 1941 port *pt = port (p);
1918 1942
1919 pt->kind &= ~flag; 1943 pt->kind &= ~flag;
… …
1939 } 1963 }
1940} 1964}
1941#endif 1965#endif
1942 1966
1943/* get new character from input file */ 1967/* get new character from input file */
1944static int 1968ecb_cold static int
1945inchar (SCHEME_P) 1969inchar (SCHEME_P)
1946{ 1970{
1947 int c; 1971 int c;
1948 port *pt = port (SCHEME_V->inport); 1972 port *pt = port (SCHEME_V->inport);
1949 1973
… …
1963 } 1987 }
1964 1988
1965 return c; 1989 return c;
1966} 1990}
1967 1991
1968static int ungot = -1; 1992ecb_cold static int
1969
1970static int
1971basic_inchar (port *pt) 1993basic_inchar (port *pt)
1972{ 1994{
1973#if USE_PORTS
1974 if (pt->unget != -1) 1995 if (pt->unget != -1)
1975 { 1996 {
1976 int r = pt->unget; 1997 int r = pt->unget;
1977 pt->unget = -1; 1998 pt->unget = -1;
1978 return r; 1999 return r;
1979 } 2000 }
1980 2001
2002#if USE_PORTS
1981 if (pt->kind & port_file) 2003 if (pt->kind & port_file)
1982 { 2004 {
1983 char c; 2005 char c;
1984 2006
1985 if (!read (pt->rep.stdio.file, &c, 1)) 2007 if (!read (pt->rep.stdio.file, &c, 1))
… …
1993 return EOF; 2015 return EOF;
1994 else 2016 else
1995 return *pt->rep.string.curr++; 2017 return *pt->rep.string.curr++;
1996 } 2018 }
1997#else 2019#else
1998 if (ungot == -1)
1999 {
2000 char c; 2020 char c;
2001 if (!read (0, &c, 1)) 2021
2022 if (!read (pt->rep.stdio.file, &c, 1))
2002 return EOF; 2023 return EOF;
2003 2024
2004 ungot = c;
2005 }
2006
2007 {
2008 int r = ungot;
2009 ungot = -1;
2010 return r; 2025 return c;
2011 }
2012#endif 2026#endif
2013} 2027}
2014 2028
2015/* back character to input buffer */ 2029/* back character to input buffer */
2016static void 2030ecb_cold static void
2017backchar (SCHEME_P_ int c) 2031backchar (SCHEME_P_ int c)
2018{ 2032{
2019#if USE_PORTS 2033 port *pt = port (SCHEME_V->inport);
2020 port *pt;
2021 2034
2022 if (c == EOF) 2035 if (c == EOF)
2023 return; 2036 return;
2024 2037
2025 pt = port (SCHEME_V->inport);
2026 pt->unget = c; 2038 pt->unget = c;
2027#else
2028 if (c == EOF)
2029 return;
2030
2031 ungot = c;
2032#endif
2033} 2039}
2034 2040
2035#if USE_PORTS 2041#if USE_PORTS
2036static int 2042ecb_cold static int
2037realloc_port_string (SCHEME_P_ port *p) 2043realloc_port_string (SCHEME_P_ port *p)
2038{ 2044{
2039 char *start = p->rep.string.start; 2045 char *start = p->rep.string.start;
2040 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2046 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2041 char *str = malloc (new_size); 2047 char *str = malloc (new_size);
… …
2054 else 2060 else
2055 return 0; 2061 return 0;
2056} 2062}
2057#endif 2063#endif
2058 2064
2059INTERFACE void 2065ecb_cold static void
2060putstr (SCHEME_P_ const char *s) 2066putchars (SCHEME_P_ const char *s, int len)
2061{ 2067{
2068 port *pt = port (SCHEME_V->outport);
2069
2062#if USE_PORTS 2070#if USE_PORTS
2063 port *pt = port (SCHEME_V->outport);
2064
2065 if (pt->kind & port_file)
2066 write (pt->rep.stdio.file, s, strlen (s));
2067 else
2068 for (; *s; s++)
2069 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2070 *pt->rep.string.curr++ = *s;
2071 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2072 *pt->rep.string.curr++ = *s;
2073
2074#else
2075 write (pt->rep.stdio.file, s, strlen (s));
2076#endif
2077}
2078
2079static void
2080putchars (SCHEME_P_ const char *s, int len)
2081{
2082#if USE_PORTS
2083 port *pt = port (SCHEME_V->outport);
2084
2085 if (pt->kind & port_file) 2071 if (pt->kind & port_file)
2086 write (pt->rep.stdio.file, s, len); 2072 write (pt->rep.stdio.file, s, len);
2087 else 2073 else
2088 { 2074 {
2089 for (; len; len--) 2075 for (; len; len--)
… …
2094 *pt->rep.string.curr++ = *s++; 2080 *pt->rep.string.curr++ = *s++;
2095 } 2081 }
2096 } 2082 }
2097 2083
2098#else 2084#else
2099 write (1, s, len); 2085 write (1, s, len); // output not initialised
2100#endif 2086#endif
2087}
2088
2089INTERFACE void
2090putstr (SCHEME_P_ const char *s)
2091{
2092 putchars (SCHEME_A_ s, strlen (s));
2101} 2093}
2102 2094
2103INTERFACE void 2095INTERFACE void
2104putcharacter (SCHEME_P_ int c) 2096putcharacter (SCHEME_P_ int c)
2105{ 2097{
2106#if USE_PORTS
2107 port *pt = port (SCHEME_V->outport);
2108
2109 if (pt->kind & port_file)
2110 {
2111 char cc = c;
2112 write (pt->rep.stdio.file, &cc, 1);
2113 }
2114 else
2115 {
2116 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2117 *pt->rep.string.curr++ = c;
2118 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2119 *pt->rep.string.curr++ = c;
2120 }
2121
2122#else
2123 char cc = c; 2098 char cc = c;
2124 write (1, &c, 1); 2099
2125#endif 2100 putchars (SCHEME_A_ &cc, 1);
2126} 2101}
2127 2102
2128/* read characters up to delimiter, but cater to character constants */ 2103/* read characters up to delimiter, but cater to character constants */
2129static char * 2104ecb_cold static char *
2130readstr_upto (SCHEME_P_ int skip, const char *delim) 2105readstr_upto (SCHEME_P_ int skip, const char *delim)
2131{ 2106{
2132 char *p = SCHEME_V->strbuff + skip; 2107 char *p = SCHEME_V->strbuff + skip;
2133 2108
2134 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2109 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
… …
2143 2118
2144 return SCHEME_V->strbuff; 2119 return SCHEME_V->strbuff;
2145} 2120}
2146 2121
2147/* read string expression "xxx...xxx" */ 2122/* read string expression "xxx...xxx" */
2148static pointer 2123ecb_cold static pointer
2149readstrexp (SCHEME_P_ char delim) 2124readstrexp (SCHEME_P_ char delim)
2150{ 2125{
2151 char *p = SCHEME_V->strbuff; 2126 char *p = SCHEME_V->strbuff;
2152 int c; 2127 int c;
2153 int c1 = 0; 2128 int c1 = 0;
… …
2191 case 'a': *p++ = '\a'; state = st_ok; break; 2166 case 'a': *p++ = '\a'; state = st_ok; break;
2192 case 'n': *p++ = '\n'; state = st_ok; break; 2167 case 'n': *p++ = '\n'; state = st_ok; break;
2193 case 'r': *p++ = '\r'; state = st_ok; break; 2168 case 'r': *p++ = '\r'; state = st_ok; break;
2194 case 't': *p++ = '\t'; state = st_ok; break; 2169 case 't': *p++ = '\t'; state = st_ok; break;
2195 2170
2196 //TODO: \whitespace eol whitespace 2171 // this overshoots the minimum requirements of r7rs
2172 case ' ':
2173 case '\t':
2174 case '\r':
2175 case '\n':
2176 skipspace (SCHEME_A);
2177 state = st_ok;
2178 break;
2197 2179
2198 //TODO: x should end in ;, not two-digit hex 2180 //TODO: x should end in ;, not two-digit hex
2199 case 'x': 2181 case 'x':
2200 case 'X': 2182 case 'X':
2201 state = st_x1; 2183 state = st_x1;
… …
2259 } 2241 }
2260 } 2242 }
2261} 2243}
2262 2244
2263/* check c is in chars */ 2245/* check c is in chars */
2264ecb_inline int 2246ecb_cold int
2265is_one_of (const char *s, int c) 2247is_one_of (const char *s, int c)
2266{ 2248{
2267 return c == EOF || !!strchr (s, c); 2249 return c == EOF || !!strchr (s, c);
2268} 2250}
2269 2251
2270/* skip white characters */ 2252/* skip white characters */
2271ecb_inline int 2253ecb_cold int
2272skipspace (SCHEME_P) 2254skipspace (SCHEME_P)
2273{ 2255{
2274 int c, curr_line = 0; 2256 int c, curr_line = 0;
2275 2257
2276 do 2258 do
… …
2296 backchar (SCHEME_A_ c); 2278 backchar (SCHEME_A_ c);
2297 return 1; 2279 return 1;
2298} 2280}
2299 2281
2300/* get token */ 2282/* get token */
2301static int 2283ecb_cold static int
2302token (SCHEME_P) 2284token (SCHEME_P)
2303{ 2285{
2304 int c = skipspace (SCHEME_A); 2286 int c = skipspace (SCHEME_A);
2305 2287
2306 if (c == EOF) 2288 if (c == EOF)
… …
2404} 2386}
2405 2387
2406/* ========== Routines for Printing ========== */ 2388/* ========== Routines for Printing ========== */
2407#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2389#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2408 2390
2409static void 2391ecb_cold static void
2410printslashstring (SCHEME_P_ char *p, int len) 2392printslashstring (SCHEME_P_ char *p, int len)
2411{ 2393{
2412 int i; 2394 int i;
2413 unsigned char *s = (unsigned char *) p; 2395 unsigned char *s = (unsigned char *) p;
2414 2396
… …
2470 2452
2471 putcharacter (SCHEME_A_ '"'); 2453 putcharacter (SCHEME_A_ '"');
2472} 2454}
2473 2455
2474/* print atoms */ 2456/* print atoms */
2475static void 2457ecb_cold static void
2476printatom (SCHEME_P_ pointer l, int f) 2458printatom (SCHEME_P_ pointer l, int f)
2477{ 2459{
2478 char *p; 2460 char *p;
2479 int len; 2461 int len;
2480 2462
2481 atom2str (SCHEME_A_ l, f, &p, &len); 2463 atom2str (SCHEME_A_ l, f, &p, &len);
2482 putchars (SCHEME_A_ p, len); 2464 putchars (SCHEME_A_ p, len);
2483} 2465}
2484 2466
2485/* Uses internal buffer unless string pointer is already available */ 2467/* Uses internal buffer unless string pointer is already available */
2486static void 2468ecb_cold static void
2487atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2469atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2488{ 2470{
2489 char *p; 2471 char *p;
2490 2472
2491 if (l == NIL) 2473 if (l == NIL)
… …
2698 return car (d); 2680 return car (d);
2699 2681
2700 p = cons (car (d), cdr (d)); 2682 p = cons (car (d), cdr (d));
2701 q = p; 2683 q = p;
2702 2684
2703 while (cdr (cdr (p)) != NIL) 2685 while (cddr (p) != NIL)
2704 { 2686 {
2705 d = cons (car (p), cdr (p)); 2687 d = cons (car (p), cdr (p));
2706 2688
2707 if (cdr (cdr (p)) != NIL) 2689 if (cddr (p) != NIL)
2708 p = cdr (d); 2690 p = cdr (d);
2709 } 2691 }
2710 2692
2711 set_cdr (p, car (cdr (p))); 2693 set_cdr (p, cadr (p));
2712 return q; 2694 return q;
2713} 2695}
2714 2696
2715/* reverse list -- produce new list */ 2697/* reverse list -- produce new list */
2716static pointer 2698ecb_hot static pointer
2717reverse (SCHEME_P_ pointer a) 2699reverse (SCHEME_P_ pointer a)
2718{ 2700{
2719 /* a must be checked by gc */ 2701 /* a must be checked by gc */
2720 pointer p = NIL; 2702 pointer p = NIL;
2721 2703
… …
2724 2706
2725 return p; 2707 return p;
2726} 2708}
2727 2709
2728/* reverse list --- in-place */ 2710/* reverse list --- in-place */
2729static pointer 2711ecb_hot static pointer
2730reverse_in_place (SCHEME_P_ pointer term, pointer list) 2712reverse_in_place (SCHEME_P_ pointer term, pointer list)
2731{ 2713{
2732 pointer result = term; 2714 pointer result = term;
2733 pointer p = list; 2715 pointer p = list;
2734 2716
… …
2742 2724
2743 return result; 2725 return result;
2744} 2726}
2745 2727
2746/* append list -- produce new list (in reverse order) */ 2728/* append list -- produce new list (in reverse order) */
2747static pointer 2729ecb_hot static pointer
2748revappend (SCHEME_P_ pointer a, pointer b) 2730revappend (SCHEME_P_ pointer a, pointer b)
2749{ 2731{
2750 pointer result = a; 2732 pointer result = a;
2751 pointer p = b; 2733 pointer p = b;
2752 2734
… …
2761 2743
2762 return S_F; /* signal an error */ 2744 return S_F; /* signal an error */
2763} 2745}
2764 2746
2765/* equivalence of atoms */ 2747/* equivalence of atoms */
2766int 2748ecb_hot int
2767eqv (pointer a, pointer b) 2749eqv (pointer a, pointer b)
2768{ 2750{
2769 if (is_string (a)) 2751 if (is_string (a))
2770 { 2752 {
2771 if (is_string (b)) 2753 if (is_string (b))
… …
2865 } 2847 }
2866 else 2848 else
2867 set_car (env, immutable_cons (slot, car (env))); 2849 set_car (env, immutable_cons (slot, car (env)));
2868} 2850}
2869 2851
2870static pointer 2852ecb_hot static pointer
2871find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2853find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2872{ 2854{
2873 pointer x, y; 2855 pointer x, y;
2874 2856
2875 for (x = env; x != NIL; x = cdr (x)) 2857 for (x = env; x != NIL; x = cdr (x))
… …
2896 return NIL; 2878 return NIL;
2897} 2879}
2898 2880
2899#else /* USE_ALIST_ENV */ 2881#else /* USE_ALIST_ENV */
2900 2882
2901ecb_inline void 2883static void
2902new_frame_in_env (SCHEME_P_ pointer old_env) 2884new_frame_in_env (SCHEME_P_ pointer old_env)
2903{ 2885{
2904 SCHEME_V->envir = immutable_cons (NIL, old_env); 2886 SCHEME_V->envir = immutable_cons (NIL, old_env);
2905 setenvironment (SCHEME_V->envir); 2887 setenvironment (SCHEME_V->envir);
2906} 2888}
2907 2889
2908ecb_inline void 2890static void
2909new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2891new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2910{ 2892{
2911 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2893 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2912} 2894}
2913 2895
2914static pointer 2896ecb_hot static pointer
2915find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2897find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2916{ 2898{
2917 pointer x, y; 2899 pointer x, y;
2918 2900
2919 for (x = env; x != NIL; x = cdr (x)) 2901 for (x = env; x != NIL; x = cdr (x))
… …
2933 return NIL; 2915 return NIL;
2934} 2916}
2935 2917
2936#endif /* USE_ALIST_ENV else */ 2918#endif /* USE_ALIST_ENV else */
2937 2919
2938ecb_inline void 2920static void
2939new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2921new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2940{ 2922{
2941 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 2923 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2942 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2924 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2943} 2925}
2944 2926
2945ecb_inline void 2927static void
2946set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2928set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2947{ 2929{
2948 set_cdr (slot, value); 2930 set_cdr (slot, value);
2949} 2931}
2950 2932
2951ecb_inline pointer 2933static pointer
2952slot_value_in_env (pointer slot) 2934slot_value_in_env (pointer slot)
2953{ 2935{
2954 return cdr (slot); 2936 return cdr (slot);
2955} 2937}
2956 2938
2957/* ========== Evaluation Cycle ========== */ 2939/* ========== Evaluation Cycle ========== */
2958 2940
2959static int 2941ecb_cold static int
2960xError_1 (SCHEME_P_ const char *s, pointer a) 2942xError_1 (SCHEME_P_ const char *s, pointer a)
2961{ 2943{
2962#if USE_ERROR_HOOK
2963 pointer x;
2964 pointer hdl = SCHEME_V->ERROR_HOOK;
2965#endif
2966
2967#if USE_PRINTF 2944#if USE_PRINTF
2968#if SHOW_ERROR_LINE 2945#if SHOW_ERROR_LINE
2969 char sbuf[STRBUFFSIZE]; 2946 char sbuf[STRBUFFSIZE];
2970 2947
2971 /* make sure error is not in REPL */ 2948 /* make sure error is not in REPL */
… …
2986 } 2963 }
2987#endif 2964#endif
2988#endif 2965#endif
2989 2966
2990#if USE_ERROR_HOOK 2967#if USE_ERROR_HOOK
2991 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 2968 pointer x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->ERROR_HOOK, 1);
2992 2969
2993 if (x != NIL) 2970 if (x != NIL)
2994 { 2971 {
2995 pointer code = a 2972 pointer code = a
2996 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL) 2973 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
… …
3040 pointer code; 3017 pointer code;
3041}; 3018};
3042 3019
3043# define STACK_GROWTH 3 3020# define STACK_GROWTH 3
3044 3021
3045static void 3022ecb_hot static void
3046s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3023s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3047{ 3024{
3048 int nframes = (uintptr_t)SCHEME_V->dump; 3025 int nframes = (uintptr_t)SCHEME_V->dump;
3049 struct dump_stack_frame *next_frame; 3026 struct dump_stack_frame *next_frame;
3050 3027
… …
3063 next_frame->code = code; 3040 next_frame->code = code;
3064 3041
3065 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3042 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3066} 3043}
3067 3044
3068static int 3045static ecb_hot int
3069xs_return (SCHEME_P_ pointer a) 3046xs_return (SCHEME_P_ pointer a)
3070{ 3047{
3071 int nframes = (uintptr_t)SCHEME_V->dump; 3048 int nframes = (uintptr_t)SCHEME_V->dump;
3072 struct dump_stack_frame *frame; 3049 struct dump_stack_frame *frame;
3073 3050
… …
3084 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3061 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3085 3062
3086 return 0; 3063 return 0;
3087} 3064}
3088 3065
3089ecb_inline void 3066ecb_cold void
3090dump_stack_reset (SCHEME_P) 3067dump_stack_reset (SCHEME_P)
3091{ 3068{
3092 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3069 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3093 SCHEME_V->dump = (pointer)+0; 3070 SCHEME_V->dump = (pointer)+0;
3094} 3071}
3095 3072
3096ecb_inline void 3073ecb_cold void
3097dump_stack_initialize (SCHEME_P) 3074dump_stack_initialize (SCHEME_P)
3098{ 3075{
3099 SCHEME_V->dump_size = 0; 3076 SCHEME_V->dump_size = 0;
3100 SCHEME_V->dump_base = 0; 3077 SCHEME_V->dump_base = 0;
3101 dump_stack_reset (SCHEME_A); 3078 dump_stack_reset (SCHEME_A);
3102} 3079}
3103 3080
3104static void 3081ecb_cold static void
3105dump_stack_free (SCHEME_P) 3082dump_stack_free (SCHEME_P)
3106{ 3083{
3107 free (SCHEME_V->dump_base); 3084 free (SCHEME_V->dump_base);
3108 SCHEME_V->dump_base = 0; 3085 SCHEME_V->dump_base = 0;
3109 SCHEME_V->dump = (pointer)0; 3086 SCHEME_V->dump = (pointer)0;
3110 SCHEME_V->dump_size = 0; 3087 SCHEME_V->dump_size = 0;
3111} 3088}
3112 3089
3113static void 3090ecb_cold static void
3114dump_stack_mark (SCHEME_P) 3091dump_stack_mark (SCHEME_P)
3115{ 3092{
3116 int nframes = (uintptr_t)SCHEME_V->dump; 3093 int nframes = (uintptr_t)SCHEME_V->dump;
3117 int i; 3094 int i;
3118 3095
… …
3124 mark (frame->envir); 3101 mark (frame->envir);
3125 mark (frame->code); 3102 mark (frame->code);
3126 } 3103 }
3127} 3104}
3128 3105
3129static pointer 3106ecb_cold static pointer
3130ss_get_cont (SCHEME_P) 3107ss_get_cont (SCHEME_P)
3131{ 3108{
3132 int nframes = (uintptr_t)SCHEME_V->dump; 3109 int nframes = (uintptr_t)SCHEME_V->dump;
3133 int i; 3110 int i;
3134 3111
… …
3146 } 3123 }
3147 3124
3148 return cont; 3125 return cont;
3149} 3126}
3150 3127
3151static void 3128ecb_cold static void
3152ss_set_cont (SCHEME_P_ pointer cont) 3129ss_set_cont (SCHEME_P_ pointer cont)
3153{ 3130{
3154 int i = 0; 3131 int i = 0;
3155 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3132 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3156 3133
… …
3168 SCHEME_V->dump = (pointer)(uintptr_t)i; 3145 SCHEME_V->dump = (pointer)(uintptr_t)i;
3169} 3146}
3170 3147
3171#else 3148#else
3172 3149
3173ecb_inline void 3150ecb_cold void
3174dump_stack_reset (SCHEME_P) 3151dump_stack_reset (SCHEME_P)
3175{ 3152{
3176 SCHEME_V->dump = NIL; 3153 SCHEME_V->dump = NIL;
3177} 3154}
3178 3155
3179ecb_inline void 3156ecb_cold void
3180dump_stack_initialize (SCHEME_P) 3157dump_stack_initialize (SCHEME_P)
3181{ 3158{
3182 dump_stack_reset (SCHEME_A); 3159 dump_stack_reset (SCHEME_A);
3183} 3160}
3184 3161
3185static void 3162ecb_cold static void
3186dump_stack_free (SCHEME_P) 3163dump_stack_free (SCHEME_P)
3187{ 3164{
3188 SCHEME_V->dump = NIL; 3165 SCHEME_V->dump = NIL;
3189} 3166}
3190 3167
3191static int 3168ecb_hot static int
3192xs_return (SCHEME_P_ pointer a) 3169xs_return (SCHEME_P_ pointer a)
3193{ 3170{
3194 pointer dump = SCHEME_V->dump; 3171 pointer dump = SCHEME_V->dump;
3195 3172
3196 SCHEME_V->value = a; 3173 SCHEME_V->value = a;
… …
3206 SCHEME_V->dump = dump; 3183 SCHEME_V->dump = dump;
3207 3184
3208 return 0; 3185 return 0;
3209} 3186}
3210 3187
3211static void 3188ecb_hot static void
3212s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3189s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3213{ 3190{
3214 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3191 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3215 cons (args, 3192 cons (args,
3216 cons (SCHEME_V->envir, 3193 cons (SCHEME_V->envir,
3217 cons (code, 3194 cons (code,
3218 SCHEME_V->dump)))); 3195 SCHEME_V->dump))));
3219} 3196}
3220 3197
3221static void 3198ecb_cold static void
3222dump_stack_mark (SCHEME_P) 3199dump_stack_mark (SCHEME_P)
3223{ 3200{
3224 mark (SCHEME_V->dump); 3201 mark (SCHEME_V->dump);
3225} 3202}
3226 3203
3227static pointer 3204ecb_cold static pointer
3228ss_get_cont (SCHEME_P) 3205ss_get_cont (SCHEME_P)
3229{ 3206{
3230 return SCHEME_V->dump; 3207 return SCHEME_V->dump;
3231} 3208}
3232 3209
3233static void 3210ecb_cold static void
3234ss_set_cont (SCHEME_P_ pointer cont) 3211ss_set_cont (SCHEME_P_ pointer cont)
3235{ 3212{
3236 SCHEME_V->dump = cont; 3213 SCHEME_V->dump = cont;
3237} 3214}
3238 3215
3239#endif 3216#endif
3240 3217
3241#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3218#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3242 3219
3243#if EXPERIMENT 3220#if EXPERIMENT
3221
3244static int 3222static int
3245debug (SCHEME_P_ int indent, pointer x) 3223dtree (SCHEME_P_ int indent, pointer x)
3246{ 3224{
3247 int c; 3225 int c;
3248 3226
3249 if (is_syntax (x)) 3227 if (is_syntax (x))
3250 { 3228 {
… …
3268 printf ("%*sS<%s>\n", indent, "", symname (x)); 3246 printf ("%*sS<%s>\n", indent, "", symname (x));
3269 return 24+8; 3247 return 24+8;
3270 3248
3271 case T_CLOSURE: 3249 case T_CLOSURE:
3272 printf ("%*sS<%s>\n", indent, "", "closure"); 3250 printf ("%*sS<%s>\n", indent, "", "closure");
3273 debug (SCHEME_A_ indent + 3, cdr(x)); 3251 dtree (SCHEME_A_ indent + 3, cdr(x));
3274 return 32 + debug (SCHEME_A_ indent + 3, car (x)); 3252 return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3275 3253
3276 case T_PAIR: 3254 case T_PAIR:
3277 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); 3255 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3278 c = debug (SCHEME_A_ indent + 3, car (x)); 3256 c = dtree (SCHEME_A_ indent + 3, car (x));
3279 c += debug (SCHEME_A_ indent + 3, cdr (x)); 3257 c += dtree (SCHEME_A_ indent + 3, cdr (x));
3280 return c + 1; 3258 return c + 1;
3281 3259
3282 case T_PORT: 3260 case T_PORT:
3283 printf ("%*sS<%s>\n", indent, "", "port"); 3261 printf ("%*sS<%s>\n", indent, "", "port");
3284 return 24+8; 3262 return 24+8;
… …
3287 printf ("%*sS<%s>\n", indent, "", "vector"); 3265 printf ("%*sS<%s>\n", indent, "", "vector");
3288 return 24+8; 3266 return 24+8;
3289 3267
3290 case T_ENVIRONMENT: 3268 case T_ENVIRONMENT:
3291 printf ("%*sS<%s>\n", indent, "", "environment"); 3269 printf ("%*sS<%s>\n", indent, "", "environment");
3292 return 0 + debug (SCHEME_A_ indent + 3, car (x)); 3270 return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3293 3271
3294 default: 3272 default:
3295 printf ("unhandled type %d\n", type (x)); 3273 printf ("unhandled type %d\n", type (x));
3296 break; 3274 break;
3297 } 3275 }
3298} 3276}
3299#endif
3300 3277
3278#define DUMP(t) do { printf ("DUMP %s:%d\n", __FILE__, __LINE__); dtree (SCHEME_A_ 0, (t)); } while (0)
3279
3280typedef void *stream[1];
3281
3282#define stream_init() { 0 }
3283#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
3284#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
3285#define stream_free(s) free (s[0])
3286
3287ecb_cold static void
3288stream_put (stream s, uint8_t byte)
3289{
3290 uint32_t *sp = *s;
3291 uint32_t size = sizeof (uint32_t) * 2;
3292 uint32_t offs = size;
3293
3294 if (ecb_expect_true (sp))
3295 {
3296 offs = sp[0];
3297 size = sp[1];
3298 }
3299
3300 if (ecb_expect_false (offs == size))
3301 {
3302 size *= 2;
3303 sp = realloc (sp, size);
3304 *s = sp;
3305 sp[1] = size;
3306
3307 }
3308
3309 ((uint8_t *)sp)[offs++] = byte;
3310 sp[0] = offs;
3311}
3312
3313ecb_cold static void
3314stream_put_v (stream s, uint32_t v)
3315{
3316 while (v > 0x7f)
3317 {
3318 stream_put (s, v | 0x80);
3319 v >>= 7;
3320 }
3321
3322 stream_put (s, v);
3323}
3324
3325ecb_cold static void
3326stream_put_tv (stream s, int bop, uint32_t v)
3327{
3328 printf ("put tv %d %d\n", bop, v);//D
3329 stream_put (s, bop);
3330 stream_put_v (s, v);
3331}
3332
3333ecb_cold static void
3334stream_put_stream (stream s, stream o)
3335{
3336 uint32_t i;
3337
3338 for (i = 0; i < stream_size (o); ++i)
3339 stream_put (s, stream_data (o)[i]);
3340
3341 stream_free (o);
3342}
3343
3344// calculates a (preferably small) integer that makes it possible to find
3345// the symbol again. if pointers were offsets into a memory area... until
3346// then, we return segment number in the low bits, and offset in the high
3347// bits.
3348// also, this function must never return 0.
3349ecb_cold static uint32_t
3350symbol_id (SCHEME_P_ pointer sym)
3351{
3352 struct cell *p = CELL (sym);
3353 int i;
3354
3355 for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3356 if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3357 return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3358
3359 abort ();
3360}
3361
3362ecb_cold static uint32_t
3363cell_id (SCHEME_P_ pointer p)
3364{
3365 return symbol_id (SCHEME_A_ p);
3366}
3367
3368enum byteop
3369{
3370 BOP_NIL,
3371 BOP_SYNTAX,
3372 BOP_INTEGER,
3373 BOP_SYMBOL,
3374 BOP_LIST_BEG,
3375 BOP_LIST_END,
3376 BOP_BIFT, // branch if true
3377 BOP_BIFF, // branch if false
3378 BOP_BIFNE, // branch if not eqv?
3379 BOP_BRA, // "short" branch
3380 BOP_JMP, // "long" jump
3381 BOP_DATUM,
3382 BOP_LET,
3383 BOP_LETAST,
3384 BOP_LETREC,
3385 BOP_DEFINE,
3386 BOP_MACRO,
3387 BOP_SET,
3388 BOP_BEGIN,
3389 BOP_LAMBDA,
3390};
3391
3392ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
3393
3394ecb_cold static void
3395compile_list (SCHEME_P_ stream s, pointer x)
3396{
3397 for (; x != NIL; x = cdr (x))
3398 compile_expr (SCHEME_A_ s, car (x));
3399}
3400
3301static int 3401static void
3402compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
3403{
3404 //TODO: borked
3405 stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
3406
3407 stream_put (s, BOP_BIFF);
3408 compile_expr (SCHEME_A_ s, cond);
3409 stream_put_v (s, stream_size (sift));
3410 stream_put_stream (s, sift);
3411
3412 if (iff != NIL)
3413 {
3414 stream siff = stream_init (); compile_expr (SCHEME_A_ siff, iff);
3415 stream_put_tv (s, BOP_BRA, stream_size (siff));
3416 stream_put_stream (s, siff);
3417 }
3418}
3419
3420typedef uint32_t stream_fixup;
3421
3422static stream_fixup
3423stream_put_fixup (stream s)
3424{
3425 stream_put (s, 0);
3426 stream_put (s, 0);
3427
3428 return stream_size (s);
3429}
3430
3431static void
3432stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target)
3433{
3434 target -= fixup;
3435 assert (target < (1 << 14));
3436 stream_data (s)[fixup - 2] = target | 0x80;
3437 stream_data (s)[fixup - 1] = target >> 7;
3438}
3439
3440static void
3441compile_and_or (SCHEME_P_ stream s, int and, pointer x)
3442{
3443 if (cdr (x) == NIL)
3444 compile_expr (SCHEME_A_ s, car (x));
3445 else
3446 {
3447 stream_put (s, and ? BOP_BIFF : BOP_BIFT);
3448 compile_expr (SCHEME_A_ s, car (x));
3449 stream_fixup end = stream_put_fixup (s);
3450
3451 compile_and_or (SCHEME_A_ s, and, cdr (x));
3452 stream_fix_fixup (s, end, stream_size (s));
3453 }
3454}
3455
3456ecb_cold static void
3457compile_expr (SCHEME_P_ stream s, pointer x)
3458{
3459 if (x == NIL)
3460 {
3461 stream_put (s, BOP_NIL);
3462 return;
3463 }
3464
3465 if (is_pair (x))
3466 {
3467 pointer head = car (x);
3468
3469 if (is_syntax (head))
3470 {
3471 x = cdr (x);
3472
3473 switch (syntaxnum (head))
3474 {
3475 case OP_IF0: /* if */
3476 compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
3477 break;
3478
3479 case OP_OR0: /* or */
3480 compile_and_or (SCHEME_A_ s, 0, x);
3481 break;
3482
3483 case OP_AND0: /* and */
3484 compile_and_or (SCHEME_A_ s, 1, x);
3485 break;
3486
3487 case OP_CASE0: /* case */
3488 abort ();
3489 break;
3490
3491 case OP_COND0: /* cond */
3492 abort ();
3493 break;
3494
3495 case OP_LET0: /* let */
3496 case OP_LET0AST: /* let* */
3497 case OP_LET0REC: /* letrec */
3498 switch (syntaxnum (head))
3499 {
3500 case OP_LET0: stream_put (s, BOP_LET ); break;
3501 case OP_LET0AST: stream_put (s, BOP_LETAST); break;
3502 case OP_LET0REC: stream_put (s, BOP_LETREC); break;
3503 }
3504
3505 {
3506 pointer bindings = car (x);
3507 pointer body = cadr (x);
3508
3509 for (x = bindings; x != NIL; x = cdr (x))
3510 {
3511 pointer init = NIL;
3512 pointer var = car (x);
3513
3514 if (is_pair (var))
3515 {
3516 init = cdr (var);
3517 var = car (var);
3518 }
3519
3520 stream_put_v (s, symbol_id (SCHEME_A_ var));
3521 compile_expr (SCHEME_A_ s, init);
3522 }
3523
3524 stream_put_v (s, 0);
3525 compile_expr (SCHEME_A_ s, body);
3526 }
3527 break;
3528
3529 case OP_DEF0: /* define */
3530 case OP_MACRO0: /* macro */
3531 stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO);
3532 stream_put_v (s, cell_id (SCHEME_A_ car (x)));
3533 compile_expr (SCHEME_A_ s, cadr (x));
3534 break;
3535
3536 case OP_SET0: /* set! */
3537 stream_put (s, BOP_SET);
3538 stream_put_v (s, symbol_id (SCHEME_A_ car (x)));
3539 compile_expr (SCHEME_A_ s, cadr (x));
3540 break;
3541
3542 case OP_BEGIN: /* begin */
3543 stream_put (s, BOP_BEGIN);
3544 compile_list (SCHEME_A_ s, x);
3545 return;
3546
3547 case OP_DELAY: /* delay */
3548 abort ();
3549 break;
3550
3551 case OP_QUOTE: /* quote */
3552 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3553 break;
3554
3555 case OP_LAMBDA: /* lambda */
3556 {
3557 pointer formals = car (x);
3558 pointer body = cadr (x);
3559
3560 stream_put (s, BOP_LAMBDA);
3561
3562 for (; is_pair (formals); formals = cdr (formals))
3563 stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
3564
3565 stream_put_v (s, 0);
3566 stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals));
3567
3568 compile_expr (SCHEME_A_ s, body);
3569 }
3570 break;
3571
3572 case OP_C0STREAM:/* cons-stream */
3573 abort ();
3574 break;
3575 }
3576
3577 return;
3578 }
3579
3580 pointer m = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, head, 1);
3581
3582 if (m != NIL)
3583 {
3584 m = slot_value_in_env (m);
3585
3586 if (is_macro (m))
3587 {
3588 s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
3589 SCHEME_V->code = m;
3590 SCHEME_V->args = cons (x, NIL);
3591 Eval_Cycle (SCHEME_A_ OP_APPLY);
3592 x = SCHEME_V->value;
3593 compile_expr (SCHEME_A_ s, SCHEME_V->value);
3594 return;
3595 }
3596 }
3597 }
3598
3599 switch (type (x))
3600 {
3601 case T_INTEGER:
3602 {
3603 IVALUE iv = ivalue_unchecked (x);
3604 iv = iv < 0 ? ((uint32_t)-iv << 1) | 1 : (uint32_t)iv << 1;
3605 stream_put_tv (s, BOP_INTEGER, iv);
3606 }
3607 return;
3608
3609 case T_SYMBOL:
3610 stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3611 return;
3612
3613 case T_PAIR:
3614 stream_put (s, BOP_LIST_BEG);
3615
3616 for (; x != NIL; x = cdr (x))
3617 compile_expr (SCHEME_A_ s, car (x));
3618
3619 stream_put (s, BOP_LIST_END);
3620 return;
3621
3622 default:
3623 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3624 break;
3625 }
3626}
3627
3628ecb_cold static int
3629compile_closure (SCHEME_P_ pointer p)
3630{
3631 stream s = stream_init ();
3632
3633 compile_list (SCHEME_A_ s, cdar (p));
3634
3635 FILE *xxd = popen ("xxd", "we");
3636 fwrite (stream_data (s), 1, stream_size (s), xxd);
3637 fclose (xxd);
3638
3639 return stream_size (s);
3640}
3641
3642#endif
3643
3644/* syntax, eval, core, ... */
3645ecb_hot static int
3302opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3646opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3303{ 3647{
3304 pointer args = SCHEME_V->args; 3648 pointer args = SCHEME_V->args;
3305 pointer x, y; 3649 pointer x, y;
3306 3650
3307 switch (op) 3651 switch (op)
3308 { 3652 {
3309#if EXPERIMENT //D 3653#if EXPERIMENT //D
3310 case OP_DEBUG: 3654 case OP_DEBUG:
3311 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3655 {
3656 uint32_t len = compile_closure (SCHEME_A_ car (args));
3657 printf ("len = %d\n", len);
3312 printf ("\n"); 3658 printf ("\n");
3313 s_return (S_T); 3659 s_return (S_T);
3660 }
3661
3662 case OP_DEBUG2:
3663 return -1;
3314#endif 3664#endif
3665
3315 case OP_LOAD: /* load */ 3666 case OP_LOAD: /* load */
3316 if (file_interactive (SCHEME_A)) 3667 if (file_interactive (SCHEME_A))
3317 { 3668 {
3318 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n"); 3669 putstr (SCHEME_A_ "Loading ");
3319 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3670 putstr (SCHEME_A_ strvalue (car (args)));
3671 putcharacter (SCHEME_A_ '\n');
3320 } 3672 }
3321 3673
3322 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3674 if (!file_push (SCHEME_A_ strvalue (car (args))))
3323 Error_1 ("unable to open", car (args)); 3675 Error_1 ("unable to open", car (args));
3324 else 3676
3325 {
3326 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3677 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3327 s_goto (OP_T0LVL); 3678 s_goto (OP_T0LVL);
3328 }
3329 3679
3330 case OP_T0LVL: /* top level */ 3680 case OP_T0LVL: /* top level */
3331 3681
3332 /* If we reached the end of file, this loop is done. */ 3682 /* If we reached the end of file, this loop is done. */
3333 if (port (SCHEME_V->loadport)->kind & port_saw_EOF) 3683 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
… …
3349 /* If interactive, be nice to user. */ 3699 /* If interactive, be nice to user. */
3350 if (file_interactive (SCHEME_A)) 3700 if (file_interactive (SCHEME_A))
3351 { 3701 {
3352 SCHEME_V->envir = SCHEME_V->global_env; 3702 SCHEME_V->envir = SCHEME_V->global_env;
3353 dump_stack_reset (SCHEME_A); 3703 dump_stack_reset (SCHEME_A);
3354 putstr (SCHEME_A_ "\n"); 3704 putcharacter (SCHEME_A_ '\n');
3705#if EXPERIMENT
3706 system ("ps v $PPID");
3707#endif
3355 putstr (SCHEME_A_ prompt); 3708 putstr (SCHEME_A_ prompt);
3356 } 3709 }
3357 3710
3358 /* Set up another iteration of REPL */ 3711 /* Set up another iteration of REPL */
3359 SCHEME_V->nesting = 0; 3712 SCHEME_V->nesting = 0;
… …
3394 { 3747 {
3395 SCHEME_V->print_flag = 1; 3748 SCHEME_V->print_flag = 1;
3396 SCHEME_V->args = SCHEME_V->value; 3749 SCHEME_V->args = SCHEME_V->value;
3397 s_goto (OP_P0LIST); 3750 s_goto (OP_P0LIST);
3398 } 3751 }
3399 else 3752
3400 s_return (SCHEME_V->value); 3753 s_return (SCHEME_V->value);
3401 3754
3402 case OP_EVAL: /* main part of evaluation */ 3755 case OP_EVAL: /* main part of evaluation */
3403#if USE_TRACING 3756#if USE_TRACING
3404 if (SCHEME_V->tracing) 3757 if (SCHEME_V->tracing)
3405 { 3758 {
… …
3438 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3791 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3439 SCHEME_V->code = x; 3792 SCHEME_V->code = x;
3440 s_goto (OP_EVAL); 3793 s_goto (OP_EVAL);
3441 } 3794 }
3442 } 3795 }
3443 else 3796
3444 s_return (SCHEME_V->code); 3797 s_return (SCHEME_V->code);
3445 3798
3446 case OP_E0ARGS: /* eval arguments */ 3799 case OP_E0ARGS: /* eval arguments */
3447 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ 3800 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3448 { 3801 {
3449 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3802 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3450 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3803 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3451 SCHEME_V->code = SCHEME_V->value; 3804 SCHEME_V->code = SCHEME_V->value;
3452 s_goto (OP_APPLY); 3805 s_goto (OP_APPLY);
3453 } 3806 }
3454 else 3807
3455 {
3456 SCHEME_V->code = cdr (SCHEME_V->code); 3808 SCHEME_V->code = cdr (SCHEME_V->code);
3457 s_goto (OP_E1ARGS); 3809 s_goto (OP_E1ARGS);
3458 }
3459 3810
3460 case OP_E1ARGS: /* eval arguments */ 3811 case OP_E1ARGS: /* eval arguments */
3461 args = cons (SCHEME_V->value, args); 3812 args = cons (SCHEME_V->value, args);
3462 3813
3463 if (is_pair (SCHEME_V->code)) /* continue */ 3814 if (is_pair (SCHEME_V->code)) /* continue */
… …
3474 SCHEME_V->args = cdr (args); 3825 SCHEME_V->args = cdr (args);
3475 s_goto (OP_APPLY); 3826 s_goto (OP_APPLY);
3476 } 3827 }
3477 3828
3478#if USE_TRACING 3829#if USE_TRACING
3479
3480 case OP_TRACING: 3830 case OP_TRACING:
3481 { 3831 {
3482 int tr = SCHEME_V->tracing; 3832 int tr = SCHEME_V->tracing;
3483 3833
3484 SCHEME_V->tracing = ivalue_unchecked (car (args)); 3834 SCHEME_V->tracing = ivalue_unchecked (car (args));
3485 s_return (mk_integer (SCHEME_A_ tr)); 3835 s_return (mk_integer (SCHEME_A_ tr));
3486 } 3836 }
3487
3488#endif 3837#endif
3489 3838
3490 case OP_APPLY: /* apply 'code' to 'args' */ 3839 case OP_APPLY: /* apply 'code' to 'args' */
3491#if USE_TRACING 3840#if USE_TRACING
3492 if (SCHEME_V->tracing) 3841 if (SCHEME_V->tracing)
… …
3546 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3895 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3547 { 3896 {
3548 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3897 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3549 s_return (args != NIL ? car (args) : NIL); 3898 s_return (args != NIL ? car (args) : NIL);
3550 } 3899 }
3551 else 3900
3552 Error_0 ("illegal function"); 3901 Error_0 ("illegal function");
3553 3902
3554 case OP_DOMACRO: /* do macro */ 3903 case OP_DOMACRO: /* do macro */
3555 SCHEME_V->code = SCHEME_V->value; 3904 SCHEME_V->code = SCHEME_V->value;
3556 s_goto (OP_EVAL); 3905 s_goto (OP_EVAL);
3557 3906
… …
3621 else 3970 else
3622 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 3971 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3623 3972
3624 s_return (SCHEME_V->code); 3973 s_return (SCHEME_V->code);
3625 3974
3626
3627 case OP_DEFP: /* defined? */ 3975 case OP_DEFP: /* defined? */
3628 x = SCHEME_V->envir; 3976 x = SCHEME_V->envir;
3629 3977
3630 if (cdr (args) != NIL) 3978 if (cdr (args) != NIL)
3631 x = cadr (args); 3979 x = cadr (args);
… …
3649 s_return (SCHEME_V->value); 3997 s_return (SCHEME_V->value);
3650 } 3998 }
3651 else 3999 else
3652 Error_1 ("set!: unbound variable:", SCHEME_V->code); 4000 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3653 4001
3654
3655 case OP_BEGIN: /* begin */ 4002 case OP_BEGIN: /* begin */
3656 if (!is_pair (SCHEME_V->code)) 4003 if (!is_pair (SCHEME_V->code))
3657 s_return (SCHEME_V->code); 4004 s_return (SCHEME_V->code);
3658 4005
3659 if (cdr (SCHEME_V->code) != NIL) 4006 if (cdr (SCHEME_V->code) != NIL)
… …
3670 case OP_IF1: /* if */ 4017 case OP_IF1: /* if */
3671 if (is_true (SCHEME_V->value)) 4018 if (is_true (SCHEME_V->value))
3672 SCHEME_V->code = car (SCHEME_V->code); 4019 SCHEME_V->code = car (SCHEME_V->code);
3673 else 4020 else
3674 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ 4021 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
4022
3675 s_goto (OP_EVAL); 4023 s_goto (OP_EVAL);
3676 4024
3677 case OP_LET0: /* let */ 4025 case OP_LET0: /* let */
3678 SCHEME_V->args = NIL; 4026 SCHEME_V->args = NIL;
3679 SCHEME_V->value = SCHEME_V->code; 4027 SCHEME_V->value = SCHEME_V->code;
3680 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); 4028 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3681 s_goto (OP_LET1); 4029 s_goto (OP_LET1);
3682 4030
3683 case OP_LET1: /* let (calculate parameters) */ 4031 case OP_LET1: /* let (calculate parameters) */
4032 case OP_LET1REC: /* letrec (calculate parameters) */
3684 args = cons (SCHEME_V->value, args); 4033 args = cons (SCHEME_V->value, args);
3685 4034
3686 if (is_pair (SCHEME_V->code)) /* continue */ 4035 if (is_pair (SCHEME_V->code)) /* continue */
3687 { 4036 {
3688 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 4037 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3689 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); 4038 Error_1 ("Bad syntax of binding spec in let/letrec:", car (SCHEME_V->code));
3690 4039
3691 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); 4040 s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code));
3692 SCHEME_V->code = cadar (SCHEME_V->code); 4041 SCHEME_V->code = cadar (SCHEME_V->code);
3693 SCHEME_V->args = NIL; 4042 SCHEME_V->args = NIL;
3694 s_goto (OP_EVAL); 4043 s_goto (OP_EVAL);
3695 } 4044 }
3696 else /* end */ 4045
3697 { 4046 /* end */
3698 args = reverse_in_place (SCHEME_A_ NIL, args); 4047 args = reverse_in_place (SCHEME_A_ NIL, args);
3699 SCHEME_V->code = car (args); 4048 SCHEME_V->code = car (args);
3700 SCHEME_V->args = cdr (args); 4049 SCHEME_V->args = cdr (args);
3701 s_goto (OP_LET2); 4050 s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC);
3702 }
3703 4051
3704 case OP_LET2: /* let */ 4052 case OP_LET2: /* let */
3705 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4053 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3706 4054
3707 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 4055 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
… …
3711 if (is_symbol (car (SCHEME_V->code))) /* named let */ 4059 if (is_symbol (car (SCHEME_V->code))) /* named let */
3712 { 4060 {
3713 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 4061 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3714 { 4062 {
3715 if (!is_pair (x)) 4063 if (!is_pair (x))
3716 Error_1 ("Bad syntax of binding in let :", x); 4064 Error_1 ("Bad syntax of binding in let:", x);
3717 4065
3718 if (!is_list (SCHEME_A_ car (x))) 4066 if (!is_list (SCHEME_A_ car (x)))
3719 Error_1 ("Bad syntax of binding in let :", car (x)); 4067 Error_1 ("Bad syntax of binding in let:", car (x));
3720 4068
3721 args = cons (caar (x), args); 4069 args = cons (caar (x), args);
3722 } 4070 }
3723 4071
3724 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)), 4072 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
… …
3741 SCHEME_V->code = cdr (SCHEME_V->code); 4089 SCHEME_V->code = cdr (SCHEME_V->code);
3742 s_goto (OP_BEGIN); 4090 s_goto (OP_BEGIN);
3743 } 4091 }
3744 4092
3745 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code))) 4093 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code)))
3746 Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code)); 4094 Error_1 ("Bad syntax of binding spec in let*:", car (SCHEME_V->code));
3747 4095
3748 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code)); 4096 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
3749 SCHEME_V->code = car (cdaar (SCHEME_V->code)); 4097 SCHEME_V->code = car (cdaar (SCHEME_V->code));
3750 s_goto (OP_EVAL); 4098 s_goto (OP_EVAL);
3751 4099
… …
3762 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code); 4110 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3763 SCHEME_V->code = cadar (SCHEME_V->code); 4111 SCHEME_V->code = cadar (SCHEME_V->code);
3764 SCHEME_V->args = NIL; 4112 SCHEME_V->args = NIL;
3765 s_goto (OP_EVAL); 4113 s_goto (OP_EVAL);
3766 } 4114 }
3767 else /* end */ 4115
4116 /* end */
3768 { 4117
3769 SCHEME_V->code = args; 4118 SCHEME_V->code = args;
3770 SCHEME_V->args = NIL; 4119 SCHEME_V->args = NIL;
3771 s_goto (OP_BEGIN); 4120 s_goto (OP_BEGIN);
3772 }
3773 4121
3774 case OP_LET0REC: /* letrec */ 4122 case OP_LET0REC: /* letrec */
3775 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4123 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3776 SCHEME_V->args = NIL; 4124 SCHEME_V->args = NIL;
3777 SCHEME_V->value = SCHEME_V->code; 4125 SCHEME_V->value = SCHEME_V->code;
3778 SCHEME_V->code = car (SCHEME_V->code); 4126 SCHEME_V->code = car (SCHEME_V->code);
3779 s_goto (OP_LET1REC); 4127 s_goto (OP_LET1REC);
3780 4128
3781 case OP_LET1REC: /* letrec (calculate parameters) */ 4129 /* OP_LET1REC handled by OP_LET1 */
3782 args = cons (SCHEME_V->value, args);
3783
3784 if (is_pair (SCHEME_V->code)) /* continue */
3785 {
3786 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3787 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3788
3789 s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3790 SCHEME_V->code = cadar (SCHEME_V->code);
3791 SCHEME_V->args = NIL;
3792 s_goto (OP_EVAL);
3793 }
3794 else /* end */
3795 {
3796 args = reverse_in_place (SCHEME_A_ NIL, args);
3797 SCHEME_V->code = car (args);
3798 SCHEME_V->args = cdr (args);
3799 s_goto (OP_LET2REC);
3800 }
3801 4130
3802 case OP_LET2REC: /* letrec */ 4131 case OP_LET2REC: /* letrec */
3803 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) 4132 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3804 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 4133 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3805 4134
… …
3835 } 4164 }
3836 else 4165 else
3837 { 4166 {
3838 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) 4167 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3839 s_return (NIL); 4168 s_return (NIL);
3840 else 4169
3841 {
3842 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 4170 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3843 SCHEME_V->code = caar (SCHEME_V->code); 4171 SCHEME_V->code = caar (SCHEME_V->code);
3844 s_goto (OP_EVAL); 4172 s_goto (OP_EVAL);
3845 }
3846 } 4173 }
3847 4174
3848 case OP_DELAY: /* delay */ 4175 case OP_DELAY: /* delay */
3849 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 4176 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3850 set_typeflag (x, T_PROMISE); 4177 set_typeflag (x, T_PROMISE);
… …
3861 case OP_AND1: /* and */ 4188 case OP_AND1: /* and */
3862 if (is_false (SCHEME_V->value)) 4189 if (is_false (SCHEME_V->value))
3863 s_return (SCHEME_V->value); 4190 s_return (SCHEME_V->value);
3864 else if (SCHEME_V->code == NIL) 4191 else if (SCHEME_V->code == NIL)
3865 s_return (SCHEME_V->value); 4192 s_return (SCHEME_V->value);
3866 else 4193
3867 {
3868 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 4194 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3869 SCHEME_V->code = car (SCHEME_V->code); 4195 SCHEME_V->code = car (SCHEME_V->code);
3870 s_goto (OP_EVAL); 4196 s_goto (OP_EVAL);
3871 }
3872 4197
3873 case OP_OR0: /* or */ 4198 case OP_OR0: /* or */
3874 if (SCHEME_V->code == NIL) 4199 if (SCHEME_V->code == NIL)
3875 s_return (S_F); 4200 s_return (S_F);
3876 4201
… …
3881 case OP_OR1: /* or */ 4206 case OP_OR1: /* or */
3882 if (is_true (SCHEME_V->value)) 4207 if (is_true (SCHEME_V->value))
3883 s_return (SCHEME_V->value); 4208 s_return (SCHEME_V->value);
3884 else if (SCHEME_V->code == NIL) 4209 else if (SCHEME_V->code == NIL)
3885 s_return (SCHEME_V->value); 4210 s_return (SCHEME_V->value);
3886 else 4211
3887 {
3888 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 4212 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3889 SCHEME_V->code = car (SCHEME_V->code); 4213 SCHEME_V->code = car (SCHEME_V->code);
3890 s_goto (OP_EVAL); 4214 s_goto (OP_EVAL);
3891 }
3892 4215
3893 case OP_C0STREAM: /* cons-stream */ 4216 case OP_C0STREAM: /* cons-stream */
3894 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 4217 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3895 SCHEME_V->code = car (SCHEME_V->code); 4218 SCHEME_V->code = car (SCHEME_V->code);
3896 s_goto (OP_EVAL); 4219 s_goto (OP_EVAL);
… …
3961 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x)); 4284 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3962 SCHEME_V->code = caar (x); 4285 SCHEME_V->code = caar (x);
3963 s_goto (OP_EVAL); 4286 s_goto (OP_EVAL);
3964 } 4287 }
3965 } 4288 }
3966 else 4289
3967 s_return (NIL); 4290 s_return (NIL);
3968 4291
3969 case OP_CASE2: /* case */ 4292 case OP_CASE2: /* case */
3970 if (is_true (SCHEME_V->value)) 4293 if (is_true (SCHEME_V->value))
3971 s_goto (OP_BEGIN); 4294 s_goto (OP_BEGIN);
3972 else 4295
3973 s_return (NIL); 4296 s_return (NIL);
3974 4297
3975 case OP_PAPPLY: /* apply */ 4298 case OP_PAPPLY: /* apply */
3976 SCHEME_V->code = car (args); 4299 SCHEME_V->code = car (args);
3977 SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); 4300 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3978 /*SCHEME_V->args = cadr(args); */ 4301 /*SCHEME_V->args = cadr(args); */
… …
3992 } 4315 }
3993 4316
3994 if (USE_ERROR_CHECKING) abort (); 4317 if (USE_ERROR_CHECKING) abort ();
3995} 4318}
3996 4319
3997static int 4320/* math, cxr */
4321ecb_hot static int
3998opexe_1 (SCHEME_P_ enum scheme_opcodes op) 4322opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3999{ 4323{
4000 pointer args = SCHEME_V->args; 4324 pointer args = SCHEME_V->args;
4001 pointer x = car (args); 4325 pointer x = car (args);
4002 num v; 4326 num v;
… …
4483 } 4807 }
4484 4808
4485 if (USE_ERROR_CHECKING) abort (); 4809 if (USE_ERROR_CHECKING) abort ();
4486} 4810}
4487 4811
4488static int 4812/* relational ops */
4813ecb_hot static int
4489opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4814opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4490{ 4815{
4491 pointer x = SCHEME_V->args; 4816 pointer x = SCHEME_V->args;
4492 4817
4493 for (;;) 4818 for (;;)
… …
4514 } 4839 }
4515 4840
4516 s_return (S_T); 4841 s_return (S_T);
4517} 4842}
4518 4843
4519static int 4844/* predicates */
4845ecb_hot static int
4520opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4846opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4521{ 4847{
4522 pointer args = SCHEME_V->args; 4848 pointer args = SCHEME_V->args;
4523 pointer a = car (args); 4849 pointer a = car (args);
4524 pointer d = cdr (args); 4850 pointer d = cdr (args);
… …
4571 } 4897 }
4572 4898
4573 s_retbool (r); 4899 s_retbool (r);
4574} 4900}
4575 4901
4576static int 4902/* promises, list ops, ports */
4903ecb_hot static int
4577opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4904opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4578{ 4905{
4579 pointer args = SCHEME_V->args; 4906 pointer args = SCHEME_V->args;
4580 pointer a = car (args); 4907 pointer a = car (args);
4581 pointer x, y; 4908 pointer x, y;
… …
4598 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4925 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4599 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); 4926 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4600 s_return (SCHEME_V->value); 4927 s_return (SCHEME_V->value);
4601 4928
4602#if USE_PORTS 4929#if USE_PORTS
4930
4931 case OP_EOF_OBJECT: /* eof-object */
4932 s_return (S_EOF);
4603 4933
4604 case OP_WRITE: /* write */ 4934 case OP_WRITE: /* write */
4605 case OP_DISPLAY: /* display */ 4935 case OP_DISPLAY: /* display */
4606 case OP_WRITE_CHAR: /* write-char */ 4936 case OP_WRITE_CHAR: /* write-char */
4607 if (is_pair (cdr (SCHEME_V->args))) 4937 if (is_pair (cdr (SCHEME_V->args)))
… …
4621 else 4951 else
4622 SCHEME_V->print_flag = 0; 4952 SCHEME_V->print_flag = 0;
4623 4953
4624 s_goto (OP_P0LIST); 4954 s_goto (OP_P0LIST);
4625 4955
4956 //TODO: move to scheme
4626 case OP_NEWLINE: /* newline */ 4957 case OP_NEWLINE: /* newline */
4627 if (is_pair (args)) 4958 if (is_pair (args))
4628 { 4959 {
4629 if (a != SCHEME_V->outport) 4960 if (a != SCHEME_V->outport)
4630 { 4961 {
… …
4632 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 4963 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4633 SCHEME_V->outport = a; 4964 SCHEME_V->outport = a;
4634 } 4965 }
4635 } 4966 }
4636 4967
4637 putstr (SCHEME_A_ "\n"); 4968 putcharacter (SCHEME_A_ '\n');
4638 s_return (S_T); 4969 s_return (S_T);
4639#endif 4970#endif
4640 4971
4641 case OP_ERR0: /* error */ 4972 case OP_ERR0: /* error */
4642 SCHEME_V->retcode = -1; 4973 SCHEME_V->retcode = -1;
… …
4651 putstr (SCHEME_A_ strvalue (car (args))); 4982 putstr (SCHEME_A_ strvalue (car (args)));
4652 SCHEME_V->args = cdr (args); 4983 SCHEME_V->args = cdr (args);
4653 s_goto (OP_ERR1); 4984 s_goto (OP_ERR1);
4654 4985
4655 case OP_ERR1: /* error */ 4986 case OP_ERR1: /* error */
4656 putstr (SCHEME_A_ " "); 4987 putcharacter (SCHEME_A_ ' ');
4657 4988
4658 if (args != NIL) 4989 if (args != NIL)
4659 { 4990 {
4660 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); 4991 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4661 SCHEME_V->args = a; 4992 SCHEME_V->args = a;
4662 SCHEME_V->print_flag = 1; 4993 SCHEME_V->print_flag = 1;
4663 s_goto (OP_P0LIST); 4994 s_goto (OP_P0LIST);
4664 } 4995 }
4665 else 4996 else
4666 { 4997 {
4667 putstr (SCHEME_A_ "\n"); 4998 putcharacter (SCHEME_A_ '\n');
4668 4999
4669 if (SCHEME_V->interactive_repl) 5000 if (SCHEME_V->interactive_repl)
4670 s_goto (OP_T0LVL); 5001 s_goto (OP_T0LVL);
4671 else 5002 else
4672 return -1; 5003 return -1;
… …
4880 } 5211 }
4881 5212
4882 if (USE_ERROR_CHECKING) abort (); 5213 if (USE_ERROR_CHECKING) abort ();
4883} 5214}
4884 5215
4885static int 5216/* reading */
5217ecb_cold static int
4886opexe_5 (SCHEME_P_ enum scheme_opcodes op) 5218opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4887{ 5219{
4888 pointer args = SCHEME_V->args; 5220 pointer args = SCHEME_V->args;
4889 pointer x; 5221 pointer x;
4890 5222
… …
4969 case OP_RDSEXPR: 5301 case OP_RDSEXPR:
4970 switch (SCHEME_V->tok) 5302 switch (SCHEME_V->tok)
4971 { 5303 {
4972 case TOK_EOF: 5304 case TOK_EOF:
4973 s_return (S_EOF); 5305 s_return (S_EOF);
4974 /* NOTREACHED */
4975 5306
4976 case TOK_VEC: 5307 case TOK_VEC:
4977 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL); 5308 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
4978 /* fall through */ 5309 /* fall through */
4979 5310
… …
4982 5313
4983 if (SCHEME_V->tok == TOK_RPAREN) 5314 if (SCHEME_V->tok == TOK_RPAREN)
4984 s_return (NIL); 5315 s_return (NIL);
4985 else if (SCHEME_V->tok == TOK_DOT) 5316 else if (SCHEME_V->tok == TOK_DOT)
4986 Error_0 ("syntax error: illegal dot expression"); 5317 Error_0 ("syntax error: illegal dot expression");
4987 else 5318
4988 {
4989 SCHEME_V->nesting_stack[SCHEME_V->file_i]++; 5319 SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
4990 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL); 5320 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
4991 s_goto (OP_RDSEXPR); 5321 s_goto (OP_RDSEXPR);
4992 }
4993 5322
4994 case TOK_QUOTE: 5323 case TOK_QUOTE:
4995 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL); 5324 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
4996 SCHEME_V->tok = token (SCHEME_A); 5325 SCHEME_V->tok = token (SCHEME_A);
4997 s_goto (OP_RDSEXPR); 5326 s_goto (OP_RDSEXPR);
… …
5003 { 5332 {
5004 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL); 5333 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5005 SCHEME_V->tok = TOK_LPAREN; 5334 SCHEME_V->tok = TOK_LPAREN;
5006 s_goto (OP_RDSEXPR); 5335 s_goto (OP_RDSEXPR);
5007 } 5336 }
5008 else 5337
5009 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); 5338 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5010
5011 s_goto (OP_RDSEXPR); 5339 s_goto (OP_RDSEXPR);
5012 5340
5013 case TOK_COMMA: 5341 case TOK_COMMA:
5014 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL); 5342 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
5015 SCHEME_V->tok = token (SCHEME_A); 5343 SCHEME_V->tok = token (SCHEME_A);
… …
5026 case TOK_DOTATOM: 5354 case TOK_DOTATOM:
5027 SCHEME_V->strbuff[0] = '.'; 5355 SCHEME_V->strbuff[0] = '.';
5028 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); 5356 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5029 5357
5030 case TOK_STRATOM: 5358 case TOK_STRATOM:
5359 //TODO: haven't checked whether the garbage collector could interfere and free x
5360 gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded
5031 x = readstrexp (SCHEME_A_ '|'); 5361 x = readstrexp (SCHEME_A_ '|');
5032 //TODO: haven't checked whether the garbage collector could interfere
5033 s_return (mk_atom (SCHEME_A_ strvalue (x))); 5362 s_return (mk_atom (SCHEME_A_ strvalue (x)));
5034 5363
5035 case TOK_DQUOTE: 5364 case TOK_DQUOTE:
5036 x = readstrexp (SCHEME_A_ '"'); 5365 x = readstrexp (SCHEME_A_ '"');
5037 5366
… …
5045 { 5374 {
5046 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1); 5375 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);
5047 5376
5048 if (f == NIL) 5377 if (f == NIL)
5049 Error_0 ("undefined sharp expression"); 5378 Error_0 ("undefined sharp expression");
5050 else 5379
5051 {
5052 SCHEME_V->code = cons (slot_value_in_env (f), NIL); 5380 SCHEME_V->code = cons (slot_value_in_env (f), NIL);
5053 s_goto (OP_EVAL); 5381 s_goto (OP_EVAL);
5054 }
5055 } 5382 }
5056 5383
5057 case TOK_SHARP_CONST: 5384 case TOK_SHARP_CONST:
5058 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL) 5385 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5059 Error_0 ("undefined sharp expression"); 5386 Error_0 ("undefined sharp expression");
5060 else 5387
5061 s_return (x); 5388 s_return (x);
5062 5389
5063 default: 5390 default:
5064 Error_0 ("syntax error: illegal token"); 5391 Error_0 ("syntax error: illegal token");
5065 } 5392 }
5066 5393
… …
5159 pointer b = cdr (args); 5486 pointer b = cdr (args);
5160 int ok_abbr = ok_abbrev (b); 5487 int ok_abbr = ok_abbrev (b);
5161 SCHEME_V->args = car (b); 5488 SCHEME_V->args = car (b);
5162 5489
5163 if (a == SCHEME_V->QUOTE && ok_abbr) 5490 if (a == SCHEME_V->QUOTE && ok_abbr)
5164 putstr (SCHEME_A_ "'"); 5491 putcharacter (SCHEME_A_ '\'');
5165 else if (a == SCHEME_V->QQUOTE && ok_abbr) 5492 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5166 putstr (SCHEME_A_ "`"); 5493 putcharacter (SCHEME_A_ '`');
5167 else if (a == SCHEME_V->UNQUOTE && ok_abbr) 5494 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5168 putstr (SCHEME_A_ ","); 5495 putcharacter (SCHEME_A_ ',');
5169 else if (a == SCHEME_V->UNQUOTESP && ok_abbr) 5496 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5170 putstr (SCHEME_A_ ",@"); 5497 putstr (SCHEME_A_ ",@");
5171 else 5498 else
5172 { 5499 {
5173 putstr (SCHEME_A_ "("); 5500 putcharacter (SCHEME_A_ '(');
5174 s_save (SCHEME_A_ OP_P1LIST, b, NIL); 5501 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5175 SCHEME_V->args = a; 5502 SCHEME_V->args = a;
5176 } 5503 }
5177 5504
5178 s_goto (OP_P0LIST); 5505 s_goto (OP_P0LIST);
… …
5180 5507
5181 case OP_P1LIST: 5508 case OP_P1LIST:
5182 if (is_pair (args)) 5509 if (is_pair (args))
5183 { 5510 {
5184 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); 5511 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5185 putstr (SCHEME_A_ " "); 5512 putcharacter (SCHEME_A_ ' ');
5186 SCHEME_V->args = car (args); 5513 SCHEME_V->args = car (args);
5187 s_goto (OP_P0LIST); 5514 s_goto (OP_P0LIST);
5188 } 5515 }
5189 else if (is_vector (args)) 5516 else if (is_vector (args))
5190 { 5517 {
… …
5198 { 5525 {
5199 putstr (SCHEME_A_ " . "); 5526 putstr (SCHEME_A_ " . ");
5200 printatom (SCHEME_A_ args, SCHEME_V->print_flag); 5527 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5201 } 5528 }
5202 5529
5203 putstr (SCHEME_A_ ")"); 5530 putcharacter (SCHEME_A_ ')');
5204 s_return (S_T); 5531 s_return (S_T);
5205 } 5532 }
5206 5533
5207 case OP_PVECFROM: 5534 case OP_PVECFROM:
5208 { 5535 {
… …
5210 pointer vec = car (args); 5537 pointer vec = car (args);
5211 int len = veclength (vec); 5538 int len = veclength (vec);
5212 5539
5213 if (i == len) 5540 if (i == len)
5214 { 5541 {
5215 putstr (SCHEME_A_ ")"); 5542 putcharacter (SCHEME_A_ ')');
5216 s_return (S_T); 5543 s_return (S_T);
5217 } 5544 }
5218 else 5545 else
5219 { 5546 {
5220 pointer elem = vector_get (vec, i); 5547 pointer elem = vector_get (vec, i);
… …
5222 ivalue_unchecked (cdr (args)) = i + 1; 5549 ivalue_unchecked (cdr (args)) = i + 1;
5223 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5550 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5224 SCHEME_V->args = elem; 5551 SCHEME_V->args = elem;
5225 5552
5226 if (i > 0) 5553 if (i > 0)
5227 putstr (SCHEME_A_ " "); 5554 putcharacter (SCHEME_A_ ' ');
5228 5555
5229 s_goto (OP_P0LIST); 5556 s_goto (OP_P0LIST);
5230 } 5557 }
5231 } 5558 }
5232 } 5559 }
5233 5560
5234 if (USE_ERROR_CHECKING) abort (); 5561 if (USE_ERROR_CHECKING) abort ();
5235} 5562}
5236 5563
5237static int 5564/* list ops */
5565ecb_hot static int
5238opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5566opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5239{ 5567{
5240 pointer args = SCHEME_V->args; 5568 pointer args = SCHEME_V->args;
5241 pointer a = car (args); 5569 pointer a = car (args);
5242 pointer x, y; 5570 pointer x, y;
… …
5265 break; 5593 break;
5266 } 5594 }
5267 5595
5268 if (is_pair (y)) 5596 if (is_pair (y))
5269 s_return (car (y)); 5597 s_return (car (y));
5270 else 5598
5271 s_return (S_F); 5599 s_return (S_F);
5272
5273 5600
5274 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5601 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5275 SCHEME_V->args = a; 5602 SCHEME_V->args = a;
5276 5603
5277 if (SCHEME_V->args == NIL) 5604 if (SCHEME_V->args == NIL)
5278 s_return (S_F); 5605 s_return (S_F);
5279 else if (is_closure (SCHEME_V->args)) 5606 else if (is_closure (SCHEME_V->args) || is_macro (SCHEME_V->args))
5280 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5607 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5281 else if (is_macro (SCHEME_V->args)) 5608
5282 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5283 else
5284 s_return (S_F); 5609 s_return (S_F);
5285 5610
5286 case OP_CLOSUREP: /* closure? */ 5611 case OP_CLOSUREP: /* closure? */
5287 /* 5612 /*
5288 * Note, macro object is also a closure. 5613 * Note, macro object is also a closure.
5289 * Therefore, (closure? <#MACRO>) ==> #t 5614 * Therefore, (closure? <#MACRO>) ==> #t
… …
5300 5625
5301/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5626/* 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); 5627typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5303 5628
5304typedef int (*test_predicate)(pointer); 5629typedef int (*test_predicate)(pointer);
5305static int 5630
5631ecb_hot static int
5306tst_any (pointer p) 5632tst_any (pointer p)
5307{ 5633{
5308 return 1; 5634 return 1;
5309} 5635}
5310 5636
5311static int 5637ecb_hot static int
5312tst_inonneg (pointer p) 5638tst_inonneg (pointer p)
5313{ 5639{
5314 return is_integer (p) && ivalue_unchecked (p) >= 0; 5640 return is_integer (p) && ivalue_unchecked (p) >= 0;
5315} 5641}
5316 5642
5317static int 5643ecb_hot static int
5318tst_is_list (SCHEME_P_ pointer p) 5644tst_is_list (SCHEME_P_ pointer p)
5319{ 5645{
5320 return p == NIL || is_pair (p); 5646 return p == NIL || is_pair (p);
5321} 5647}
5322 5648
… …
5365#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" 5691#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5366#include "opdefines.h" 5692#include "opdefines.h"
5367#undef OP_DEF 5693#undef OP_DEF
5368; 5694;
5369 5695
5370static const char * 5696ecb_cold static const char *
5371opname (int idx) 5697opname (int idx)
5372{ 5698{
5373 const char *name = opnames; 5699 const char *name = opnames;
5374 5700
5375 /* should do this at compile time, but would require external program, right? */ 5701 /* should do this at compile time, but would require external program, right? */
… …
5377 name += strlen (name) + 1; 5703 name += strlen (name) + 1;
5378 5704
5379 return *name ? name : "ILLEGAL"; 5705 return *name ? name : "ILLEGAL";
5380} 5706}
5381 5707
5382static const char * 5708ecb_cold static const char *
5383procname (pointer x) 5709procname (pointer x)
5384{ 5710{
5385 return opname (procnum (x)); 5711 return opname (procnum (x));
5386} 5712}
5387 5713
… …
5407#undef OP_DEF 5733#undef OP_DEF
5408 {0} 5734 {0}
5409}; 5735};
5410 5736
5411/* kernel of this interpreter */ 5737/* kernel of this interpreter */
5412static void ecb_hot 5738ecb_hot static void
5413Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5739Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5414{ 5740{
5415 SCHEME_V->op = op; 5741 SCHEME_V->op = op;
5416 5742
5417 for (;;) 5743 for (;;)
… …
5508 } 5834 }
5509} 5835}
5510 5836
5511/* ========== Initialization of internal keywords ========== */ 5837/* ========== Initialization of internal keywords ========== */
5512 5838
5513static void 5839ecb_cold static void
5514assign_syntax (SCHEME_P_ const char *name) 5840assign_syntax (SCHEME_P_ const char *name)
5515{ 5841{
5516 pointer x = oblist_add_by_name (SCHEME_A_ name); 5842 pointer x = oblist_add_by_name (SCHEME_A_ name);
5517 set_typeflag (x, typeflag (x) | T_SYNTAX); 5843 set_typeflag (x, typeflag (x) | T_SYNTAX);
5518} 5844}
5519 5845
5520static void 5846ecb_cold static void
5521assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5847assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5522{ 5848{
5523 pointer x = mk_symbol (SCHEME_A_ name); 5849 pointer x = mk_symbol (SCHEME_A_ name);
5524 pointer y = mk_proc (SCHEME_A_ op); 5850 pointer y = mk_proc (SCHEME_A_ op);
5525 new_slot_in_env (SCHEME_A_ x, y); 5851 new_slot_in_env (SCHEME_A_ x, y);
… …
5533 ivalue_unchecked (y) = op; 5859 ivalue_unchecked (y) = op;
5534 return y; 5860 return y;
5535} 5861}
5536 5862
5537/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5863/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5538static int 5864ecb_hot static int
5539syntaxnum (pointer p) 5865syntaxnum (pointer p)
5540{ 5866{
5541 const char *s = strvalue (p); 5867 const char *s = strvalue (p);
5542 5868
5543 switch (strlength (p)) 5869 switch (strlength (p))
… …
5660#endif 5986#endif
5661 } 5987 }
5662 5988
5663 SCHEME_V->gc_verbose = 0; 5989 SCHEME_V->gc_verbose = 0;
5664 dump_stack_initialize (SCHEME_A); 5990 dump_stack_initialize (SCHEME_A);
5665 SCHEME_V->code = NIL; 5991 SCHEME_V->code = NIL;
5666 SCHEME_V->args = NIL; 5992 SCHEME_V->args = NIL;
5667 SCHEME_V->envir = NIL; 5993 SCHEME_V->envir = NIL;
5994 SCHEME_V->value = NIL;
5668 SCHEME_V->tracing = 0; 5995 SCHEME_V->tracing = 0;
5669 5996
5670 /* init NIL */ 5997 /* init NIL */
5671 set_typeflag (NIL, T_ATOM | T_MARK); 5998 set_typeflag (NIL, T_ATOM | T_MARK);
5672 set_car (NIL, NIL); 5999 set_car (NIL, NIL);
… …
5728 6055
5729 return !SCHEME_V->no_memory; 6056 return !SCHEME_V->no_memory;
5730} 6057}
5731 6058
5732#if USE_PORTS 6059#if USE_PORTS
5733void 6060ecb_cold void
5734scheme_set_input_port_file (SCHEME_P_ int fin) 6061scheme_set_input_port_file (SCHEME_P_ int fin)
5735{ 6062{
5736 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 6063 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5737} 6064}
5738 6065
5739void 6066ecb_cold void
5740scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 6067scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5741{ 6068{
5742 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 6069 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5743} 6070}
5744 6071
5745void 6072ecb_cold void
5746scheme_set_output_port_file (SCHEME_P_ int fout) 6073scheme_set_output_port_file (SCHEME_P_ int fout)
5747{ 6074{
5748 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 6075 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5749} 6076}
5750 6077
5751void 6078ecb_cold void
5752scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 6079scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5753{ 6080{
5754 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 6081 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5755} 6082}
5756#endif 6083#endif
5757 6084
5758void 6085ecb_cold void
5759scheme_set_external_data (SCHEME_P_ void *p) 6086scheme_set_external_data (SCHEME_P_ void *p)
5760{ 6087{
5761 SCHEME_V->ext_data = p; 6088 SCHEME_V->ext_data = p;
5762} 6089}
5763 6090
… …
5795 SCHEME_V->loadport = NIL; 6122 SCHEME_V->loadport = NIL;
5796 SCHEME_V->gc_verbose = 0; 6123 SCHEME_V->gc_verbose = 0;
5797 gc (SCHEME_A_ NIL, NIL); 6124 gc (SCHEME_A_ NIL, NIL);
5798 6125
5799 for (i = 0; i <= SCHEME_V->last_cell_seg; i++) 6126 for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5800 free (SCHEME_V->alloc_seg[i]); 6127 free (SCHEME_V->cell_seg[i]);
5801 6128
5802#if SHOW_ERROR_LINE 6129#if SHOW_ERROR_LINE
5803 for (i = 0; i <= SCHEME_V->file_i; i++) 6130 for (i = 0; i <= SCHEME_V->file_i; i++)
5804 {
5805 if (SCHEME_V->load_stack[i].kind & port_file) 6131 if (SCHEME_V->load_stack[i].kind & port_file)
5806 { 6132 {
5807 fname = SCHEME_V->load_stack[i].rep.stdio.filename; 6133 fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5808 6134
5809 if (fname) 6135 if (fname)
5810 free (fname); 6136 free (fname);
5811 } 6137 }
5812 }
5813#endif 6138#endif
5814} 6139}
5815 6140
5816void 6141ecb_cold void
5817scheme_load_file (SCHEME_P_ int fin) 6142scheme_load_file (SCHEME_P_ int fin)
5818{ 6143{
5819 scheme_load_named_file (SCHEME_A_ fin, 0); 6144 scheme_load_named_file (SCHEME_A_ fin, 0);
5820} 6145}
5821 6146
5822void 6147ecb_cold void
5823scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 6148scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5824{ 6149{
5825 dump_stack_reset (SCHEME_A); 6150 dump_stack_reset (SCHEME_A);
5826 SCHEME_V->envir = SCHEME_V->global_env; 6151 SCHEME_V->envir = SCHEME_V->global_env;
5827 SCHEME_V->file_i = 0; 6152 SCHEME_V->file_i = 0;
5828 SCHEME_V->load_stack[0].unget = -1; 6153 SCHEME_V->load_stack[0].unget = -1;
5829 SCHEME_V->load_stack[0].kind = port_input | port_file; 6154 SCHEME_V->load_stack[0].kind = port_input | port_file;
5830 SCHEME_V->load_stack[0].rep.stdio.file = fin; 6155 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); 6156 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5833#endif
5834 SCHEME_V->retcode = 0; 6157 SCHEME_V->retcode = 0;
5835 6158
5836#if USE_PORTS
5837 if (fin == STDIN_FILENO) 6159 if (fin == STDIN_FILENO)
5838 SCHEME_V->interactive_repl = 1; 6160 SCHEME_V->interactive_repl = 1;
5839#endif
5840 6161
5841#if USE_PORTS 6162#if USE_PORTS
5842#if SHOW_ERROR_LINE 6163#if SHOW_ERROR_LINE
5843 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0; 6164 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5844 6165
… …
5848#endif 6169#endif
5849 6170
5850 SCHEME_V->inport = SCHEME_V->loadport; 6171 SCHEME_V->inport = SCHEME_V->loadport;
5851 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6172 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5852 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6173 Eval_Cycle (SCHEME_A_ OP_T0LVL);
6174
5853 set_typeflag (SCHEME_V->loadport, T_ATOM); 6175 set_typeflag (SCHEME_V->loadport, T_ATOM);
5854 6176
5855 if (SCHEME_V->retcode == 0) 6177 if (SCHEME_V->retcode == 0)
5856 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6178 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5857} 6179}
5858 6180
5859void 6181ecb_cold void
5860scheme_load_string (SCHEME_P_ const char *cmd) 6182scheme_load_string (SCHEME_P_ const char *cmd)
5861{ 6183{
6184#if USE_PORTs
5862 dump_stack_reset (SCHEME_A); 6185 dump_stack_reset (SCHEME_A);
5863 SCHEME_V->envir = SCHEME_V->global_env; 6186 SCHEME_V->envir = SCHEME_V->global_env;
5864 SCHEME_V->file_i = 0; 6187 SCHEME_V->file_i = 0;
5865 SCHEME_V->load_stack[0].kind = port_input | port_string; 6188 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 */ 6189 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); 6190 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; 6191 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); 6192 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5871#endif
5872 SCHEME_V->retcode = 0; 6193 SCHEME_V->retcode = 0;
5873 SCHEME_V->interactive_repl = 0; 6194 SCHEME_V->interactive_repl = 0;
5874 SCHEME_V->inport = SCHEME_V->loadport; 6195 SCHEME_V->inport = SCHEME_V->loadport;
5875 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6196 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5876 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6197 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5877 set_typeflag (SCHEME_V->loadport, T_ATOM); 6198 set_typeflag (SCHEME_V->loadport, T_ATOM);
5878 6199
5879 if (SCHEME_V->retcode == 0) 6200 if (SCHEME_V->retcode == 0)
5880 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6201 SCHEME_V->retcode = SCHEME_V->nesting != 0;
6202#else
6203 abort ();
6204#endif
5881} 6205}
5882 6206
5883void 6207ecb_cold void
5884scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 6208scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5885{ 6209{
5886 pointer x; 6210 pointer x;
5887 6211
5888 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 6212 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5893 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 6217 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5894} 6218}
5895 6219
5896#if !STANDALONE 6220#if !STANDALONE
5897 6221
5898void 6222ecb_cold void
5899scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 6223scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5900{ 6224{
5901 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 6225 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5902} 6226}
5903 6227
5904void 6228ecb_cold void
5905scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 6229scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5906{ 6230{
5907 int i; 6231 int i;
5908 6232
5909 for (i = 0; i < count; i++) 6233 for (i = 0; i < count; i++)
5910 scheme_register_foreign_func (SCHEME_A_ list + i); 6234 scheme_register_foreign_func (SCHEME_A_ list + i);
5911} 6235}
5912 6236
5913pointer 6237ecb_cold pointer
5914scheme_apply0 (SCHEME_P_ const char *procname) 6238scheme_apply0 (SCHEME_P_ const char *procname)
5915{ 6239{
5916 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 6240 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5917} 6241}
5918 6242
5919void 6243ecb_cold void
5920save_from_C_call (SCHEME_P) 6244save_from_C_call (SCHEME_P)
5921{ 6245{
5922 pointer saved_data = cons (car (S_SINK), 6246 pointer saved_data = cons (car (S_SINK),
5923 cons (SCHEME_V->envir, 6247 cons (SCHEME_V->envir,
5924 SCHEME_V->dump)); 6248 SCHEME_V->dump));
… …
5928 /* Truncate the dump stack so TS will return here when done, not 6252 /* Truncate the dump stack so TS will return here when done, not
5929 directly resume pre-C-call operations. */ 6253 directly resume pre-C-call operations. */
5930 dump_stack_reset (SCHEME_A); 6254 dump_stack_reset (SCHEME_A);
5931} 6255}
5932 6256
5933void 6257ecb_cold void
5934restore_from_C_call (SCHEME_P) 6258restore_from_C_call (SCHEME_P)
5935{ 6259{
5936 set_car (S_SINK, caar (SCHEME_V->c_nest)); 6260 set_car (S_SINK, caar (SCHEME_V->c_nest));
5937 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 6261 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5938 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 6262 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5939 /* Pop */ 6263 /* Pop */
5940 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 6264 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5941} 6265}
5942 6266
5943/* "func" and "args" are assumed to be already eval'ed. */ 6267/* "func" and "args" are assumed to be already eval'ed. */
5944pointer 6268ecb_cold pointer
5945scheme_call (SCHEME_P_ pointer func, pointer args) 6269scheme_call (SCHEME_P_ pointer func, pointer args)
5946{ 6270{
5947 int old_repl = SCHEME_V->interactive_repl; 6271 int old_repl = SCHEME_V->interactive_repl;
5948 6272
5949 SCHEME_V->interactive_repl = 0; 6273 SCHEME_V->interactive_repl = 0;
… …
5956 SCHEME_V->interactive_repl = old_repl; 6280 SCHEME_V->interactive_repl = old_repl;
5957 restore_from_C_call (SCHEME_A); 6281 restore_from_C_call (SCHEME_A);
5958 return SCHEME_V->value; 6282 return SCHEME_V->value;
5959} 6283}
5960 6284
5961pointer 6285ecb_cold pointer
5962scheme_eval (SCHEME_P_ pointer obj) 6286scheme_eval (SCHEME_P_ pointer obj)
5963{ 6287{
5964 int old_repl = SCHEME_V->interactive_repl; 6288 int old_repl = SCHEME_V->interactive_repl;
5965 6289
5966 SCHEME_V->interactive_repl = 0; 6290 SCHEME_V->interactive_repl = 0;
… …
5978 6302
5979/* ========== Main ========== */ 6303/* ========== Main ========== */
5980 6304
5981#if STANDALONE 6305#if STANDALONE
5982 6306
5983int 6307ecb_cold int
5984main (int argc, char **argv) 6308main (int argc, char **argv)
5985{ 6309{
5986# if USE_MULTIPLICITY 6310# if USE_MULTIPLICITY
5987 scheme ssc; 6311 scheme ssc;
5988 scheme *const SCHEME_V = &ssc; 6312 scheme *const SCHEME_V = &ssc;
… …
5990# endif 6314# endif
5991 int fin; 6315 int fin;
5992 char *file_name = InitFile; 6316 char *file_name = InitFile;
5993 int retcode; 6317 int retcode;
5994 int isfile = 1; 6318 int isfile = 1;
6319#if EXPERIMENT
5995 system ("ps v $PPID");//D 6320 system ("ps v $PPID");
6321#endif
5996 6322
5997 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6323 if (argc == 2 && strcmp (argv[1], "-?") == 0)
5998 { 6324 {
5999 putstr (SCHEME_A_ "Usage: tinyscheme -?\n"); 6325 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6000 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n"); 6326 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
… …
6029 } 6355 }
6030#endif 6356#endif
6031 6357
6032 do 6358 do
6033 { 6359 {
6034#if USE_PORTS
6035 if (strcmp (file_name, "-") == 0) 6360 if (strcmp (file_name, "-") == 0)
6036 fin = STDIN_FILENO; 6361 fin = STDIN_FILENO;
6037 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) 6362 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
6038 { 6363 {
6039 pointer args = NIL; 6364 pointer args = NIL;
… …
6057 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args); 6382 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
6058 6383
6059 } 6384 }
6060 else 6385 else
6061 fin = open (file_name, O_RDONLY); 6386 fin = open (file_name, O_RDONLY);
6062#endif
6063 6387
6064 if (isfile && fin < 0) 6388 if (isfile && fin < 0)
6065 { 6389 {
6066 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); 6390 putstr (SCHEME_A_ "Could not open file ");
6391 putstr (SCHEME_A_ file_name);
6392 putcharacter (SCHEME_A_ '\n');
6067 } 6393 }
6068 else 6394 else
6069 { 6395 {
6070 if (isfile) 6396 if (isfile)
6071 scheme_load_named_file (SCHEME_A_ fin, file_name); 6397 scheme_load_named_file (SCHEME_A_ fin, file_name);
6072 else 6398 else
6073 scheme_load_string (SCHEME_A_ file_name); 6399 scheme_load_string (SCHEME_A_ file_name);
6074 6400
6075#if USE_PORTS
6076 if (!isfile || fin != STDIN_FILENO) 6401 if (!isfile || fin != STDIN_FILENO)
6077 { 6402 {
6078 if (SCHEME_V->retcode != 0) 6403 if (SCHEME_V->retcode != 0)
6079 { 6404 {
6080 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); 6405 putstr (SCHEME_A_ "Errors encountered reading ");
6406 putstr (SCHEME_A_ file_name);
6407 putcharacter (SCHEME_A_ '\n');
6081 } 6408 }
6082 6409
6083 if (isfile) 6410 if (isfile)
6084 close (fin); 6411 close (fin);
6085 } 6412 }
6086#endif
6087 } 6413 }
6088 6414
6089 file_name = *argv++; 6415 file_name = *argv++;
6090 } 6416 }
6091 while (file_name != 0); 6417 while (file_name != 0);

Diff Legend

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