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.59 by root, Tue Dec 1 07:13:25 2015 UTC vs.
Revision 1.68 by root, Mon Dec 7 21:12:56 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 _POSIX_C_SOURCE 200201
22 22#define _XOPEN_SOURCE 600
23#if 1 23#define _GNU_SOURCE 1 /* for malloc mremap */
24#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
25#include "malloc.c"
26#endif
27 24
28#define SCHEME_SOURCE 25#define SCHEME_SOURCE
29#include "scheme-private.h" 26#include "scheme-private.h"
30#ifndef WIN32 27#ifndef WIN32
31# include <unistd.h> 28# include <unistd.h>
32#endif 29#endif
33#if USE_MATH 30#if USE_MATH
34# include <math.h> 31# include <math.h>
35#endif 32#endif
36 33
34#define ECB_NO_THREADS 1
37#include "ecb.h" 35#include "ecb.h"
38 36
39#include <sys/types.h> 37#include <sys/types.h>
40#include <sys/stat.h> 38#include <sys/stat.h>
41#include <fcntl.h> 39#include <fcntl.h>
… …
49#include <string.h> 47#include <string.h>
50 48
51#include <limits.h> 49#include <limits.h>
52#include <inttypes.h> 50#include <inttypes.h>
53#include <float.h> 51#include <float.h>
54//#include <ctype.h> 52
53#if !USE_SYSTEM_MALLOC
54# define PAGE_SIZE 4096 /* does not work on sparc/alpha */
55# include "malloc.c"
56# define malloc(n) tiny_malloc (n)
57# define realloc(p,n) tiny_realloc (p, n)
58# define free(p) tiny_free (p)
59#endif
55 60
56#if '1' != '0' + 1 \ 61#if '1' != '0' + 1 \
57 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \ 62 || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
58 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \ 63 || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
59 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \ 64 || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
… …
91 96
92#if !USE_MULTIPLICITY 97#if !USE_MULTIPLICITY
93static scheme sc; 98static scheme sc;
94#endif 99#endif
95 100
96static void 101ecb_cold static void
97xbase (char *s, long n, int base) 102xbase (char *s, long n, int base)
98{ 103{
99 if (n < 0) 104 if (n < 0)
100 { 105 {
101 *s++ = '-'; 106 *s++ = '-';
… …
116 char x = *s; *s = *p; *p = x; 121 char x = *s; *s = *p; *p = x;
117 --p; ++s; 122 --p; ++s;
118 } 123 }
119} 124}
120 125
121static void 126ecb_cold static void
122xnum (char *s, long n) 127xnum (char *s, long n)
123{ 128{
124 xbase (s, n, 10); 129 xbase (s, n, 10);
125} 130}
126 131
127static void 132ecb_cold static void
128putnum (SCHEME_P_ long n) 133putnum (SCHEME_P_ long n)
129{ 134{
130 char buf[64]; 135 char buf[64];
131 136
132 xnum (buf, n); 137 xnum (buf, n);
133 putstr (SCHEME_A_ buf); 138 putstr (SCHEME_A_ buf);
134} 139}
140
141#if USE_CHAR_CLASSIFIERS
142#include <ctype.h>
143#else
135 144
136static char 145static char
137xtoupper (char c) 146xtoupper (char c)
138{ 147{
139 if (c >= 'a' && c <= 'z') 148 if (c >= 'a' && c <= 'z')
… …
159 168
160#define toupper(c) xtoupper (c) 169#define toupper(c) xtoupper (c)
161#define tolower(c) xtolower (c) 170#define tolower(c) xtolower (c)
162#define isdigit(c) xisdigit (c) 171#define isdigit(c) xisdigit (c)
163 172
173#endif
174
164#if USE_IGNORECASE 175#if USE_IGNORECASE
165static const char * 176ecb_cold static const char *
166xstrlwr (char *s) 177xstrlwr (char *s)
167{ 178{
168 const char *p = s; 179 const char *p = s;
169 180
170 while (*s) 181 while (*s)
… …
183# define stricmp(a,b) strcmp (a, b) 194# define stricmp(a,b) strcmp (a, b)
184# define strlwr(s) (s) 195# define strlwr(s) (s)
185#endif 196#endif
186 197
187#ifndef prompt 198#ifndef prompt
188# define prompt "ts> " 199# define prompt "ms> "
189#endif 200#endif
190 201
191#ifndef InitFile 202#ifndef InitFile
192# define InitFile "init.scm" 203# define InitFile "init.scm"
193#endif 204#endif
… …
200 T_STRING, 211 T_STRING,
201 T_SYMBOL, 212 T_SYMBOL,
202 T_PROC, 213 T_PROC,
203 T_PAIR, /* also used for free cells */ 214 T_PAIR, /* also used for free cells */
204 T_CLOSURE, 215 T_CLOSURE,
216 T_BYTECODE, // temp
205 T_MACRO, 217 T_MACRO,
206 T_CONTINUATION, 218 T_CONTINUATION,
207 T_FOREIGN, 219 T_FOREIGN,
208 T_PORT, 220 T_PORT,
209 T_VECTOR, 221 T_VECTOR,
210 T_PROMISE, 222 T_PROMISE,
211 T_ENVIRONMENT, 223 T_ENVIRONMENT,
212 /* one more... */ 224 T_SPECIAL, // #t, #f, '(), eof-object
225
213 T_NUM_SYSTEM_TYPES 226 T_NUM_SYSTEM_TYPES
214}; 227};
215 228
216#define T_MASKTYPE 0x000f 229#define T_MASKTYPE 0x001f
217#define T_SYNTAX 0x0010 230#define T_SYNTAX 0x0020
218#define T_IMMUTABLE 0x0020 231#define T_IMMUTABLE 0x0040
219#define T_ATOM 0x0040 /* only for gc */ 232#define T_ATOM 0x0080 /* only for gc */
220#define T_MARK 0x0080 /* only for gc */ 233//#define T_MARK 0x0080 /* only for gc */
221 234
222/* num, for generic arithmetic */ 235/* num, for generic arithmetic */
223struct num 236struct num
224{ 237{
225 IVALUE ivalue; 238 IVALUE ivalue;
… …
316string_value (pointer p) 329string_value (pointer p)
317{ 330{
318 return strvalue (p); 331 return strvalue (p);
319} 332}
320 333
321#define ivalue_unchecked(p) CELL(p)->object.ivalue 334#define ivalue_unchecked(p) (CELL(p)->object.ivalue + 0)
322#define set_ivalue(p,v) CELL(p)->object.ivalue = (v) 335#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
323 336
324#if USE_REAL 337#if USE_REAL
325#define rvalue_unchecked(p) CELL(p)->object.rvalue 338#define rvalue_unchecked(p) CELL(p)->object.rvalue
326#define set_rvalue(p,v) CELL(p)->object.rvalue = (v) 339#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
… …
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}
… …
496 511
497#define is_atom(p) (typeflag (p) & T_ATOM) 512#define is_atom(p) (typeflag (p) & T_ATOM)
498#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 513#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
499#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) 514#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
500 515
516#if 1
517#define is_mark(p) (CELL(p)->mark)
518#define setmark(p) (CELL(p)->mark = 1)
519#define clrmark(p) (CELL(p)->mark = 0)
520#else
501#define is_mark(p) (typeflag (p) & T_MARK) 521#define is_mark(p) (typeflag (p) & T_MARK)
502#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 522#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
503#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 523#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
524#endif
504 525
505INTERFACE int 526INTERFACE int
506is_immutable (pointer p) 527is_immutable (pointer p)
507{ 528{
508 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 529 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
… …
520 proper list: length 541 proper list: length
521 circular list: -1 542 circular list: -1
522 not even a pair: -2 543 not even a pair: -2
523 dotted list: -2 minus length before dot 544 dotted list: -2 minus length before dot
524*/ 545*/
525INTERFACE int 546ecb_hot INTERFACE int
526list_length (SCHEME_P_ pointer a) 547list_length (SCHEME_P_ pointer a)
527{ 548{
528 int i = 0; 549 int i = 0;
529 pointer slow, fast; 550 pointer slow, fast;
530 551
… …
569{ 590{
570 return list_length (SCHEME_A_ a) >= 0; 591 return list_length (SCHEME_A_ a) >= 0;
571} 592}
572 593
573#if USE_CHAR_CLASSIFIERS 594#if USE_CHAR_CLASSIFIERS
595
574ecb_inline int 596ecb_inline int
575Cisalpha (int c) 597Cisalpha (int c)
576{ 598{
577 return isascii (c) && isalpha (c); 599 return isascii (c) && isalpha (c);
578} 600}
… …
636 "gs", 658 "gs",
637 "rs", 659 "rs",
638 "us" 660 "us"
639}; 661};
640 662
641static int 663ecb_cold static int
642is_ascii_name (const char *name, int *pc) 664is_ascii_name (const char *name, int *pc)
643{ 665{
644 int i; 666 int i;
645 667
646 for (i = 0; i < 32; i++) 668 for (i = 0; i < 32; i++)
… …
668static int file_interactive (SCHEME_P); 690static int file_interactive (SCHEME_P);
669ecb_inline int is_one_of (const char *s, int c); 691ecb_inline int is_one_of (const char *s, int c);
670static int alloc_cellseg (SCHEME_P); 692static int alloc_cellseg (SCHEME_P);
671ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 693ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
672static void finalize_cell (SCHEME_P_ pointer a); 694static 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); 695static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
675static pointer mk_number (SCHEME_P_ const num n); 696static pointer mk_number (SCHEME_P_ const num n);
676static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill); 697static char *store_string (SCHEME_P_ uint32_t len, const char *str, char fill);
677static pointer mk_vector (SCHEME_P_ uint32_t len); 698static pointer mk_vector (SCHEME_P_ uint32_t len);
678static pointer mk_atom (SCHEME_P_ char *q); 699static pointer mk_atom (SCHEME_P_ char *q);
679static pointer mk_sharp_const (SCHEME_P_ char *name); 700static pointer mk_sharp_const (SCHEME_P_ char *name);
680 701
702static pointer mk_port (SCHEME_P_ port *p);
703
681#if USE_PORTS 704#if USE_PORTS
682static pointer mk_port (SCHEME_P_ port *p);
683static pointer port_from_filename (SCHEME_P_ const char *fn, int prop); 705static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
684static pointer port_from_file (SCHEME_P_ int, int prop); 706static pointer port_from_file (SCHEME_P_ int, int prop);
685static pointer port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop); 707static 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); 708static port *port_rep_from_filename (SCHEME_P_ const char *fn, int prop);
687static port *port_rep_from_file (SCHEME_P_ int, int prop); 709static 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); 710static 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); 711static void port_close (SCHEME_P_ pointer p, int flag);
690#endif 712#endif
713
691static void mark (pointer a); 714static void mark (pointer a);
692static void gc (SCHEME_P_ pointer a, pointer b); 715static void gc (SCHEME_P_ pointer a, pointer b);
693static int basic_inchar (port *pt); 716static int basic_inchar (port *pt);
694static int inchar (SCHEME_P); 717static int inchar (SCHEME_P);
695static void backchar (SCHEME_P_ int c); 718static void backchar (SCHEME_P_ int c);
696static char *readstr_upto (SCHEME_P_ int skip, const char *delim); 719static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
697static pointer readstrexp (SCHEME_P_ char delim); 720static pointer readstrexp (SCHEME_P_ char delim);
698ecb_inline int skipspace (SCHEME_P); 721static int skipspace (SCHEME_P);
699static int token (SCHEME_P); 722static int token (SCHEME_P);
700static void printslashstring (SCHEME_P_ char *s, int len); 723static void printslashstring (SCHEME_P_ char *s, int len);
701static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen); 724static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
702static void printatom (SCHEME_P_ pointer l, int f); 725static void printatom (SCHEME_P_ pointer l, int f);
703static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 726static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
883#endif 906#endif
884#endif 907#endif
885} 908}
886 909
887/* allocate new cell segment */ 910/* allocate new cell segment */
888static int 911ecb_cold static int
889alloc_cellseg (SCHEME_P) 912alloc_cellseg (SCHEME_P)
890{ 913{
891 struct cell *newp; 914 struct cell *newp;
892 struct cell *last; 915 struct cell *last;
893 struct cell *p; 916 struct cell *p;
… …
902 925
903 if (!cp && USE_ERROR_CHECKING) 926 if (!cp && USE_ERROR_CHECKING)
904 return k; 927 return k;
905 928
906 i = ++SCHEME_V->last_cell_seg; 929 i = ++SCHEME_V->last_cell_seg;
907 SCHEME_V->alloc_seg[i] = cp;
908 930
909 newp = (struct cell *)cp; 931 newp = (struct cell *)cp;
910 SCHEME_V->cell_seg[i] = newp; 932 SCHEME_V->cell_seg[i] = newp;
911 SCHEME_V->cell_segsize[i] = segsize; 933 SCHEME_V->cell_segsize[i] = segsize;
912 SCHEME_V->fcells += segsize; 934 SCHEME_V->fcells += segsize;
913 last = newp + segsize - 1; 935 last = newp + segsize - 1;
914 936
915 for (p = newp; p <= last; p++) 937 for (p = newp; p <= last; p++)
916 { 938 {
917 pointer cp = POINTER (p); 939 pointer cp = POINTER (p);
940 clrmark (cp);
918 set_typeflag (cp, T_PAIR); 941 set_typeflag (cp, T_PAIR);
919 set_car (cp, NIL); 942 set_car (cp, NIL);
920 set_cdr (cp, POINTER (p + 1)); 943 set_cdr (cp, POINTER (p + 1));
921 } 944 }
922 945
… …
935 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 958 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
936 return S_SINK; 959 return S_SINK;
937 960
938 if (SCHEME_V->free_cell == NIL) 961 if (SCHEME_V->free_cell == NIL)
939 { 962 {
940 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 1; 963 const int min_to_be_recovered = SCHEME_V->cell_segsize [SCHEME_V->last_cell_seg] >> 2;
941 964
942 gc (SCHEME_A_ a, b); 965 gc (SCHEME_A_ a, b);
943 966
944 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 967 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
945 { 968 {
… …
964 } 987 }
965} 988}
966 989
967/* To retain recent allocs before interpreter knows about them - 990/* To retain recent allocs before interpreter knows about them -
968 Tehom */ 991 Tehom */
969static void 992ecb_hot static void
970push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 993push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
971{ 994{
972 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 995 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
973 996
974 set_typeflag (holder, T_PAIR); 997 set_typeflag (holder, T_PAIR);
… …
976 set_car (holder, recent); 999 set_car (holder, recent);
977 set_cdr (holder, car (S_SINK)); 1000 set_cdr (holder, car (S_SINK));
978 set_car (S_SINK, holder); 1001 set_car (S_SINK, holder);
979} 1002}
980 1003
981static pointer 1004ecb_hot static pointer
982get_cell (SCHEME_P_ pointer a, pointer b) 1005get_cell (SCHEME_P_ pointer a, pointer b)
983{ 1006{
984 pointer cell = get_cell_x (SCHEME_A_ a, b); 1007 pointer cell = get_cell_x (SCHEME_A_ a, b);
985 1008
986 /* For right now, include "a" and "b" in "cell" so that gc doesn't 1009 /* For right now, include "a" and "b" in "cell" so that gc doesn't
… …
1043#endif 1066#endif
1044 1067
1045/* Medium level cell allocation */ 1068/* Medium level cell allocation */
1046 1069
1047/* get new cons cell */ 1070/* get new cons cell */
1048pointer 1071ecb_hot static pointer
1049xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1072xcons (SCHEME_P_ pointer a, pointer b)
1050{ 1073{
1051 pointer x = get_cell (SCHEME_A_ a, b); 1074 pointer x = get_cell (SCHEME_A_ a, b);
1052 1075
1053 set_typeflag (x, T_PAIR); 1076 set_typeflag (x, T_PAIR);
1054
1055 if (immutable)
1056 setimmutable (x);
1057 1077
1058 set_car (x, a); 1078 set_car (x, a);
1059 set_cdr (x, b); 1079 set_cdr (x, b);
1060 1080
1061 return x; 1081 return x;
1062} 1082}
1063 1083
1064static pointer 1084ecb_hot static pointer
1085ximmutable_cons (SCHEME_P_ pointer a, pointer b)
1086{
1087 pointer x = xcons (SCHEME_A_ a, b);
1088 setimmutable (x);
1089 return x;
1090}
1091
1092#define cons(a,b) xcons (SCHEME_A_ a, b)
1093#define immutable_cons(a,b) ximmutable_cons (SCHEME_A_ a, b)
1094
1095ecb_cold static pointer
1065generate_symbol (SCHEME_P_ const char *name) 1096generate_symbol (SCHEME_P_ const char *name)
1066{ 1097{
1067 pointer x = mk_string (SCHEME_A_ name); 1098 pointer x = mk_string (SCHEME_A_ name);
1068 setimmutable (x); 1099 setimmutable (x);
1069 set_typeflag (x, T_SYMBOL | T_ATOM); 1100 set_typeflag (x, T_SYMBOL | T_ATOM);
… …
1075#ifndef USE_OBJECT_LIST 1106#ifndef USE_OBJECT_LIST
1076 1107
1077static int 1108static int
1078hash_fn (const char *key, int table_size) 1109hash_fn (const char *key, int table_size)
1079{ 1110{
1080 const unsigned char *p = key; 1111 const unsigned char *p = (unsigned char *)key;
1081 uint32_t hash = 2166136261; 1112 uint32_t hash = 2166136261U;
1082 1113
1083 while (*p) 1114 while (*p)
1084 hash = (hash ^ *p++) * 16777619; 1115 hash = (hash ^ *p++) * 16777619;
1085 1116
1086 return hash % table_size; 1117 return hash % table_size;
1087} 1118}
1088 1119
1089static pointer 1120ecb_cold static pointer
1090oblist_initial_value (SCHEME_P) 1121oblist_initial_value (SCHEME_P)
1091{ 1122{
1092 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1123 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1093} 1124}
1094 1125
1095/* returns the new symbol */ 1126/* returns the new symbol */
1096static pointer 1127ecb_cold static pointer
1097oblist_add_by_name (SCHEME_P_ const char *name) 1128oblist_add_by_name (SCHEME_P_ const char *name)
1098{ 1129{
1099 pointer x = generate_symbol (SCHEME_A_ name); 1130 pointer x = generate_symbol (SCHEME_A_ name);
1100 int location = hash_fn (name, veclength (SCHEME_V->oblist)); 1131 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))); 1132 vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
1102 return x; 1133 return x;
1103} 1134}
1104 1135
1105ecb_inline pointer 1136ecb_cold static pointer
1106oblist_find_by_name (SCHEME_P_ const char *name) 1137oblist_find_by_name (SCHEME_P_ const char *name)
1107{ 1138{
1108 int location; 1139 int location;
1109 pointer x; 1140 pointer x;
1110 char *s; 1141 char *s;
… …
1121 } 1152 }
1122 1153
1123 return NIL; 1154 return NIL;
1124} 1155}
1125 1156
1126static pointer 1157ecb_cold static pointer
1127oblist_all_symbols (SCHEME_P) 1158oblist_all_symbols (SCHEME_P)
1128{ 1159{
1129 int i; 1160 int i;
1130 pointer x; 1161 pointer x;
1131 pointer ob_list = NIL; 1162 pointer ob_list = NIL;
… …
1137 return ob_list; 1168 return ob_list;
1138} 1169}
1139 1170
1140#else 1171#else
1141 1172
1142static pointer 1173ecb_cold static pointer
1143oblist_initial_value (SCHEME_P) 1174oblist_initial_value (SCHEME_P)
1144{ 1175{
1145 return NIL; 1176 return NIL;
1146} 1177}
1147 1178
1148ecb_inline pointer 1179ecb_cold static pointer
1149oblist_find_by_name (SCHEME_P_ const char *name) 1180oblist_find_by_name (SCHEME_P_ const char *name)
1150{ 1181{
1151 pointer x; 1182 pointer x;
1152 char *s; 1183 char *s;
1153 1184
… …
1162 1193
1163 return NIL; 1194 return NIL;
1164} 1195}
1165 1196
1166/* returns the new symbol */ 1197/* returns the new symbol */
1167static pointer 1198ecb_cold static pointer
1168oblist_add_by_name (SCHEME_P_ const char *name) 1199oblist_add_by_name (SCHEME_P_ const char *name)
1169{ 1200{
1170 pointer x = generate_symbol (SCHEME_A_ name); 1201 pointer x = generate_symbol (SCHEME_A_ name);
1171 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1202 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1172 return x; 1203 return x;
1173} 1204}
1174 1205
1175static pointer 1206ecb_cold static pointer
1176oblist_all_symbols (SCHEME_P) 1207oblist_all_symbols (SCHEME_P)
1177{ 1208{
1178 return SCHEME_V->oblist; 1209 return SCHEME_V->oblist;
1179} 1210}
1180 1211
1181#endif 1212#endif
1182 1213
1183#if USE_PORTS
1184static pointer 1214ecb_cold static pointer
1185mk_port (SCHEME_P_ port *p) 1215mk_port (SCHEME_P_ port *p)
1186{ 1216{
1187 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1217 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1188 1218
1189 set_typeflag (x, T_PORT | T_ATOM); 1219 set_typeflag (x, T_PORT | T_ATOM);
1190 set_port (x, p); 1220 set_port (x, p);
1191 1221
1192 return x; 1222 return x;
1193} 1223}
1194#endif
1195 1224
1196pointer 1225ecb_cold pointer
1197mk_foreign_func (SCHEME_P_ foreign_func f) 1226mk_foreign_func (SCHEME_P_ foreign_func f)
1198{ 1227{
1199 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1228 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1200 1229
1201 set_typeflag (x, T_FOREIGN | T_ATOM); 1230 set_typeflag (x, T_FOREIGN | T_ATOM);
… …
1230 if (!*pp) 1259 if (!*pp)
1231 { 1260 {
1232 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1261 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1233 1262
1234 set_typeflag (x, T_INTEGER | T_ATOM); 1263 set_typeflag (x, T_INTEGER | T_ATOM);
1235 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */ 1264 setimmutable (x); /* shouldn't do anything, doesn't cost anything */
1236 set_ivalue (x, n); 1265 set_ivalue (x, n);
1237 1266
1238 *pp = x; 1267 *pp = x;
1239 } 1268 }
1240 1269
… …
1366 x = oblist_add_by_name (SCHEME_A_ name); 1395 x = oblist_add_by_name (SCHEME_A_ name);
1367 1396
1368 return x; 1397 return x;
1369} 1398}
1370 1399
1371INTERFACE pointer 1400ecb_cold INTERFACE pointer
1372gensym (SCHEME_P) 1401gensym (SCHEME_P)
1373{ 1402{
1374 pointer x; 1403 pointer x;
1375 char name[40] = "gensym-"; 1404 char name[40] = "gensym-";
1376 xnum (name + 7, ++SCHEME_V->gensym_cnt); 1405 xnum (name + 7, ++SCHEME_V->gensym_cnt);
… …
1383{ 1412{
1384 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x; 1413 return is_symbol (x) && oblist_find_by_name (SCHEME_A_ strvalue (x)) != x;
1385} 1414}
1386 1415
1387/* make symbol or number atom from string */ 1416/* make symbol or number atom from string */
1388static pointer 1417ecb_cold static pointer
1389mk_atom (SCHEME_P_ char *q) 1418mk_atom (SCHEME_P_ char *q)
1390{ 1419{
1391 char c, *p; 1420 char c, *p;
1392 int has_dec_point = 0; 1421 int has_dec_point = 0;
1393 int has_fp_exp = 0; 1422 int has_fp_exp = 0;
… …
1464 1493
1465 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1494 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1466} 1495}
1467 1496
1468/* make constant */ 1497/* make constant */
1469static pointer 1498ecb_cold static pointer
1470mk_sharp_const (SCHEME_P_ char *name) 1499mk_sharp_const (SCHEME_P_ char *name)
1471{ 1500{
1472 if (!strcmp (name, "t")) 1501 if (!strcmp (name, "t"))
1473 return S_T; 1502 return S_T;
1474 else if (!strcmp (name, "f")) 1503 else if (!strcmp (name, "f"))
… …
1517 return mk_character (SCHEME_A_ c); 1546 return mk_character (SCHEME_A_ c);
1518 } 1547 }
1519 else 1548 else
1520 { 1549 {
1521 /* identify base by string index */ 1550 /* identify base by string index */
1522 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x"; 1551 const char baseidx[18] = "ffbf" "ffff" "ofdf" "ffff" "x";
1523 char *base = strchr (baseidx, *name); 1552 char *base = strchr (baseidx, *name);
1524 1553
1525 if (base) 1554 if (base && *base)
1526 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx)); 1555 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1527 1556
1528 return NIL; 1557 return NIL;
1529 } 1558 }
1530} 1559}
1531 1560
1532/* ========== garbage collector ========== */ 1561/* ========== garbage collector ========== */
1562
1563static void
1564finalize_cell (SCHEME_P_ pointer a)
1565{
1566 /* TODO, fast bitmap check? */
1567 if (is_string (a) || is_symbol (a))
1568 free (strvalue (a));
1569 else if (is_vector (a))
1570 free (vecvalue (a));
1571#if USE_PORTS
1572 else if (is_port (a))
1573 {
1574 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1575 port_close (SCHEME_A_ a, port_input | port_output);
1576
1577 free (port (a));
1578 }
1579#endif
1580}
1533 1581
1534/*-- 1582/*--
1535 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, 1583 * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
1536 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1584 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1537 * for marking. 1585 * for marking.
1538 * 1586 *
1539 * The exception is vectors - vectors are currently marked recursively, 1587 * The exception is vectors - vectors are currently marked recursively,
1540 * which is inherited form tinyscheme and could be fixed by having another 1588 * which is inherited form tinyscheme and could be fixed by having another
1541 * word of context in the vector 1589 * word of context in the vector
1542 */ 1590 */
1543static void 1591ecb_hot static void
1544mark (pointer a) 1592mark (pointer a)
1545{ 1593{
1546 pointer t, q, p; 1594 pointer t, q, p;
1547 1595
1548 t = 0; 1596 t = 0;
… …
1605 p = q; 1653 p = q;
1606 goto E6; 1654 goto E6;
1607 } 1655 }
1608} 1656}
1609 1657
1610/* garbage collection. parameter a, b is marked. */ 1658ecb_hot static void
1611static void 1659gc_free (SCHEME_P)
1612gc (SCHEME_P_ pointer a, pointer b)
1613{ 1660{
1614 int i; 1661 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; 1662 uint32_t total = 0;
1659 1663
1660 /* Here we scan the cells to build the free-list. */ 1664 /* Here we scan the cells to build the free-list. */
1661 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1665 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1662 { 1666 {
… …
1691 { 1695 {
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"); 1696 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 } 1697 }
1694} 1698}
1695 1699
1696static void 1700/* garbage collection. parameter a, b is marked. */
1697finalize_cell (SCHEME_P_ pointer a) 1701ecb_cold static void
1702gc (SCHEME_P_ pointer a, pointer b)
1698{ 1703{
1699 /* TODO, fast bitmap check? */ 1704 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 1705
1710 free (port (a)); 1706 if (SCHEME_V->gc_verbose)
1711 } 1707 putstr (SCHEME_A_ "gc...");
1708
1709 /* mark system globals */
1710 mark (SCHEME_V->oblist);
1711 mark (SCHEME_V->global_env);
1712
1713 /* mark current registers */
1714 mark (SCHEME_V->args);
1715 mark (SCHEME_V->envir);
1716 mark (SCHEME_V->code);
1717 dump_stack_mark (SCHEME_A);
1718 mark (SCHEME_V->value);
1719 mark (SCHEME_V->inport);
1720 mark (SCHEME_V->save_inport);
1721 mark (SCHEME_V->outport);
1722 mark (SCHEME_V->loadport);
1723
1724 /* Mark recent objects the interpreter doesn't know about yet. */
1725 mark (car (S_SINK));
1726 /* Mark any older stuff above nested C calls */
1727 mark (SCHEME_V->c_nest);
1728
1729#if USE_INTCACHE
1730 /* mark intcache */
1731 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1732 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1733 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1712#endif 1734#endif
1735
1736 /* mark variables a, b */
1737 mark (a);
1738 mark (b);
1739
1740 /* garbage collect */
1741 clrmark (NIL);
1742 SCHEME_V->fcells = 0;
1743 SCHEME_V->free_cell = NIL;
1744
1745 if (SCHEME_V->gc_verbose)
1746 putstr (SCHEME_A_ "freeing...");
1747
1748 gc_free (SCHEME_A);
1713} 1749}
1714 1750
1715/* ========== Routines for Reading ========== */ 1751/* ========== Routines for Reading ========== */
1716 1752
1717static int 1753ecb_cold static int
1718file_push (SCHEME_P_ const char *fname) 1754file_push (SCHEME_P_ const char *fname)
1719{ 1755{
1720#if USE_PORTS
1721 int fin; 1756 int fin;
1722 1757
1723 if (SCHEME_V->file_i == MAXFIL - 1) 1758 if (SCHEME_V->file_i == MAXFIL - 1)
1724 return 0; 1759 return 0;
1725 1760
… …
1742 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0); 1777 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.filename = store_string (SCHEME_A_ strlen (fname), fname, 0);
1743#endif 1778#endif
1744 } 1779 }
1745 1780
1746 return fin >= 0; 1781 return fin >= 0;
1747
1748#else
1749 return 1;
1750#endif
1751} 1782}
1752 1783
1753static void 1784ecb_cold static void
1754file_pop (SCHEME_P) 1785file_pop (SCHEME_P)
1755{ 1786{
1756 if (SCHEME_V->file_i != 0) 1787 if (SCHEME_V->file_i != 0)
1757 { 1788 {
1758 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1789 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
… …
1762 SCHEME_V->file_i--; 1793 SCHEME_V->file_i--;
1763 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i); 1794 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1764 } 1795 }
1765} 1796}
1766 1797
1767static int 1798ecb_cold static int
1768file_interactive (SCHEME_P) 1799file_interactive (SCHEME_P)
1769{ 1800{
1770#if USE_PORTS 1801#if USE_PORTS
1771 return SCHEME_V->file_i == 0 1802 return SCHEME_V->file_i == 0
1772 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1803 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
… …
1775 return 0; 1806 return 0;
1776#endif 1807#endif
1777} 1808}
1778 1809
1779#if USE_PORTS 1810#if USE_PORTS
1780static port * 1811ecb_cold static port *
1781port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1812port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1782{ 1813{
1783 int fd; 1814 int fd;
1784 int flags; 1815 int flags;
1785 char *rw; 1816 char *rw;
… …
1808# endif 1839# endif
1809 1840
1810 return pt; 1841 return pt;
1811} 1842}
1812 1843
1813static pointer 1844ecb_cold static pointer
1814port_from_filename (SCHEME_P_ const char *fn, int prop) 1845port_from_filename (SCHEME_P_ const char *fn, int prop)
1815{ 1846{
1816 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1847 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1817 1848
1818 if (!pt && USE_ERROR_CHECKING) 1849 if (!pt && USE_ERROR_CHECKING)
1819 return NIL; 1850 return NIL;
1820 1851
1821 return mk_port (SCHEME_A_ pt); 1852 return mk_port (SCHEME_A_ pt);
1822} 1853}
1823 1854
1824static port * 1855ecb_cold static port *
1825port_rep_from_file (SCHEME_P_ int f, int prop) 1856port_rep_from_file (SCHEME_P_ int f, int prop)
1826{ 1857{
1827 port *pt = malloc (sizeof *pt); 1858 port *pt = malloc (sizeof *pt);
1828 1859
1829 if (!pt && USE_ERROR_CHECKING) 1860 if (!pt && USE_ERROR_CHECKING)
… …
1834 pt->rep.stdio.file = f; 1865 pt->rep.stdio.file = f;
1835 pt->rep.stdio.closeit = 0; 1866 pt->rep.stdio.closeit = 0;
1836 return pt; 1867 return pt;
1837} 1868}
1838 1869
1839static pointer 1870ecb_cold static pointer
1840port_from_file (SCHEME_P_ int f, int prop) 1871port_from_file (SCHEME_P_ int f, int prop)
1841{ 1872{
1842 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1873 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1843 1874
1844 if (!pt && USE_ERROR_CHECKING) 1875 if (!pt && USE_ERROR_CHECKING)
1845 return NIL; 1876 return NIL;
1846 1877
1847 return mk_port (SCHEME_A_ pt); 1878 return mk_port (SCHEME_A_ pt);
1848} 1879}
1849 1880
1850static port * 1881ecb_cold static port *
1851port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1882port_rep_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1852{ 1883{
1853 port *pt = malloc (sizeof (port)); 1884 port *pt = malloc (sizeof (port));
1854 1885
1855 if (!pt && USE_ERROR_CHECKING) 1886 if (!pt && USE_ERROR_CHECKING)
… …
1861 pt->rep.string.curr = start; 1892 pt->rep.string.curr = start;
1862 pt->rep.string.past_the_end = past_the_end; 1893 pt->rep.string.past_the_end = past_the_end;
1863 return pt; 1894 return pt;
1864} 1895}
1865 1896
1866static pointer 1897ecb_cold static pointer
1867port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop) 1898port_from_string (SCHEME_P_ char *start, char *past_the_end, int prop)
1868{ 1899{
1869 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop); 1900 port *pt = port_rep_from_string (SCHEME_A_ start, past_the_end, prop);
1870 1901
1871 if (!pt && USE_ERROR_CHECKING) 1902 if (!pt && USE_ERROR_CHECKING)
… …
1874 return mk_port (SCHEME_A_ pt); 1905 return mk_port (SCHEME_A_ pt);
1875} 1906}
1876 1907
1877# define BLOCK_SIZE 256 1908# define BLOCK_SIZE 256
1878 1909
1879static port * 1910ecb_cold static port *
1880port_rep_from_scratch (SCHEME_P) 1911port_rep_from_scratch (SCHEME_P)
1881{ 1912{
1882 char *start; 1913 char *start;
1883 port *pt = malloc (sizeof (port)); 1914 port *pt = malloc (sizeof (port));
1884 1915
… …
1898 pt->rep.string.curr = start; 1929 pt->rep.string.curr = start;
1899 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1930 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1900 return pt; 1931 return pt;
1901} 1932}
1902 1933
1903static pointer 1934ecb_cold static pointer
1904port_from_scratch (SCHEME_P) 1935port_from_scratch (SCHEME_P)
1905{ 1936{
1906 port *pt = port_rep_from_scratch (SCHEME_A); 1937 port *pt = port_rep_from_scratch (SCHEME_A);
1907 1938
1908 if (!pt && USE_ERROR_CHECKING) 1939 if (!pt && USE_ERROR_CHECKING)
1909 return NIL; 1940 return NIL;
1910 1941
1911 return mk_port (SCHEME_A_ pt); 1942 return mk_port (SCHEME_A_ pt);
1912} 1943}
1913 1944
1914static void 1945ecb_cold static void
1915port_close (SCHEME_P_ pointer p, int flag) 1946port_close (SCHEME_P_ pointer p, int flag)
1916{ 1947{
1917 port *pt = port (p); 1948 port *pt = port (p);
1918 1949
1919 pt->kind &= ~flag; 1950 pt->kind &= ~flag;
… …
1939 } 1970 }
1940} 1971}
1941#endif 1972#endif
1942 1973
1943/* get new character from input file */ 1974/* get new character from input file */
1944static int 1975ecb_cold static int
1945inchar (SCHEME_P) 1976inchar (SCHEME_P)
1946{ 1977{
1947 int c; 1978 int c;
1948 port *pt = port (SCHEME_V->inport); 1979 port *pt = port (SCHEME_V->inport);
1949 1980
… …
1963 } 1994 }
1964 1995
1965 return c; 1996 return c;
1966} 1997}
1967 1998
1968static int ungot = -1; 1999ecb_cold static int
1969
1970static int
1971basic_inchar (port *pt) 2000basic_inchar (port *pt)
1972{ 2001{
1973#if USE_PORTS
1974 if (pt->unget != -1) 2002 if (pt->unget != -1)
1975 { 2003 {
1976 int r = pt->unget; 2004 int r = pt->unget;
1977 pt->unget = -1; 2005 pt->unget = -1;
1978 return r; 2006 return r;
1979 } 2007 }
1980 2008
2009#if USE_PORTS
1981 if (pt->kind & port_file) 2010 if (pt->kind & port_file)
1982 { 2011 {
1983 char c; 2012 char c;
1984 2013
1985 if (!read (pt->rep.stdio.file, &c, 1)) 2014 if (!read (pt->rep.stdio.file, &c, 1))
… …
1993 return EOF; 2022 return EOF;
1994 else 2023 else
1995 return *pt->rep.string.curr++; 2024 return *pt->rep.string.curr++;
1996 } 2025 }
1997#else 2026#else
1998 if (ungot == -1)
1999 {
2000 char c; 2027 char c;
2001 if (!read (0, &c, 1)) 2028
2029 if (!read (pt->rep.stdio.file, &c, 1))
2002 return EOF; 2030 return EOF;
2003 2031
2004 ungot = c;
2005 }
2006
2007 {
2008 int r = ungot;
2009 ungot = -1;
2010 return r; 2032 return c;
2011 }
2012#endif 2033#endif
2013} 2034}
2014 2035
2015/* back character to input buffer */ 2036/* back character to input buffer */
2016static void 2037ecb_cold static void
2017backchar (SCHEME_P_ int c) 2038backchar (SCHEME_P_ int c)
2018{ 2039{
2019#if USE_PORTS 2040 port *pt = port (SCHEME_V->inport);
2020 port *pt;
2021 2041
2022 if (c == EOF) 2042 if (c == EOF)
2023 return; 2043 return;
2024 2044
2025 pt = port (SCHEME_V->inport);
2026 pt->unget = c; 2045 pt->unget = c;
2027#else
2028 if (c == EOF)
2029 return;
2030
2031 ungot = c;
2032#endif
2033} 2046}
2034 2047
2035#if USE_PORTS 2048#if USE_PORTS
2036static int 2049ecb_cold static int
2037realloc_port_string (SCHEME_P_ port *p) 2050realloc_port_string (SCHEME_P_ port *p)
2038{ 2051{
2039 char *start = p->rep.string.start; 2052 char *start = p->rep.string.start;
2040 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE; 2053 size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
2041 char *str = malloc (new_size); 2054 char *str = malloc (new_size);
… …
2054 else 2067 else
2055 return 0; 2068 return 0;
2056} 2069}
2057#endif 2070#endif
2058 2071
2059INTERFACE void 2072ecb_cold static void
2060putstr (SCHEME_P_ const char *s) 2073putchars (SCHEME_P_ const char *s, int len)
2061{ 2074{
2075 port *pt = port (SCHEME_V->outport);
2076
2062#if USE_PORTS 2077#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) 2078 if (pt->kind & port_file)
2086 write (pt->rep.stdio.file, s, len); 2079 write (pt->rep.stdio.file, s, len);
2087 else 2080 else
2088 { 2081 {
2089 for (; len; len--) 2082 for (; len; len--)
… …
2094 *pt->rep.string.curr++ = *s++; 2087 *pt->rep.string.curr++ = *s++;
2095 } 2088 }
2096 } 2089 }
2097 2090
2098#else 2091#else
2099 write (1, s, len); 2092 write (1, s, len); // output not initialised
2100#endif 2093#endif
2094}
2095
2096INTERFACE void
2097putstr (SCHEME_P_ const char *s)
2098{
2099 putchars (SCHEME_A_ s, strlen (s));
2101} 2100}
2102 2101
2103INTERFACE void 2102INTERFACE void
2104putcharacter (SCHEME_P_ int c) 2103putcharacter (SCHEME_P_ int c)
2105{ 2104{
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; 2105 char cc = c;
2124 write (1, &c, 1); 2106
2125#endif 2107 putchars (SCHEME_A_ &cc, 1);
2126} 2108}
2127 2109
2128/* read characters up to delimiter, but cater to character constants */ 2110/* read characters up to delimiter, but cater to character constants */
2129static char * 2111ecb_cold static char *
2130readstr_upto (SCHEME_P_ int skip, const char *delim) 2112readstr_upto (SCHEME_P_ int skip, const char *delim)
2131{ 2113{
2132 char *p = SCHEME_V->strbuff + skip; 2114 char *p = SCHEME_V->strbuff + skip;
2133 2115
2134 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A)))); 2116 while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
… …
2143 2125
2144 return SCHEME_V->strbuff; 2126 return SCHEME_V->strbuff;
2145} 2127}
2146 2128
2147/* read string expression "xxx...xxx" */ 2129/* read string expression "xxx...xxx" */
2148static pointer 2130ecb_cold static pointer
2149readstrexp (SCHEME_P_ char delim) 2131readstrexp (SCHEME_P_ char delim)
2150{ 2132{
2151 char *p = SCHEME_V->strbuff; 2133 char *p = SCHEME_V->strbuff;
2152 int c; 2134 int c;
2153 int c1 = 0; 2135 int c1 = 0;
… …
2191 case 'a': *p++ = '\a'; state = st_ok; break; 2173 case 'a': *p++ = '\a'; state = st_ok; break;
2192 case 'n': *p++ = '\n'; state = st_ok; break; 2174 case 'n': *p++ = '\n'; state = st_ok; break;
2193 case 'r': *p++ = '\r'; state = st_ok; break; 2175 case 'r': *p++ = '\r'; state = st_ok; break;
2194 case 't': *p++ = '\t'; state = st_ok; break; 2176 case 't': *p++ = '\t'; state = st_ok; break;
2195 2177
2196 //TODO: \whitespace eol whitespace 2178 // this overshoots the minimum requirements of r7rs
2179 case ' ':
2180 case '\t':
2181 case '\r':
2182 case '\n':
2183 skipspace (SCHEME_A);
2184 state = st_ok;
2185 break;
2197 2186
2198 //TODO: x should end in ;, not two-digit hex 2187 //TODO: x should end in ;, not two-digit hex
2199 case 'x': 2188 case 'x':
2200 case 'X': 2189 case 'X':
2201 state = st_x1; 2190 state = st_x1;
… …
2259 } 2248 }
2260 } 2249 }
2261} 2250}
2262 2251
2263/* check c is in chars */ 2252/* check c is in chars */
2264ecb_inline int 2253ecb_cold int
2265is_one_of (const char *s, int c) 2254is_one_of (const char *s, int c)
2266{ 2255{
2267 return c == EOF || !!strchr (s, c); 2256 return c == EOF || !!strchr (s, c);
2268} 2257}
2269 2258
2270/* skip white characters */ 2259/* skip white characters */
2271ecb_inline int 2260ecb_cold int
2272skipspace (SCHEME_P) 2261skipspace (SCHEME_P)
2273{ 2262{
2274 int c, curr_line = 0; 2263 int c, curr_line = 0;
2275 2264
2276 do 2265 do
… …
2296 backchar (SCHEME_A_ c); 2285 backchar (SCHEME_A_ c);
2297 return 1; 2286 return 1;
2298} 2287}
2299 2288
2300/* get token */ 2289/* get token */
2301static int 2290ecb_cold static int
2302token (SCHEME_P) 2291token (SCHEME_P)
2303{ 2292{
2304 int c = skipspace (SCHEME_A); 2293 int c = skipspace (SCHEME_A);
2305 2294
2306 if (c == EOF) 2295 if (c == EOF)
… …
2404} 2393}
2405 2394
2406/* ========== Routines for Printing ========== */ 2395/* ========== Routines for Printing ========== */
2407#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2396#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2408 2397
2409static void 2398ecb_cold static void
2410printslashstring (SCHEME_P_ char *p, int len) 2399printslashstring (SCHEME_P_ char *p, int len)
2411{ 2400{
2412 int i; 2401 int i;
2413 unsigned char *s = (unsigned char *) p; 2402 unsigned char *s = (unsigned char *) p;
2414 2403
… …
2470 2459
2471 putcharacter (SCHEME_A_ '"'); 2460 putcharacter (SCHEME_A_ '"');
2472} 2461}
2473 2462
2474/* print atoms */ 2463/* print atoms */
2475static void 2464ecb_cold static void
2476printatom (SCHEME_P_ pointer l, int f) 2465printatom (SCHEME_P_ pointer l, int f)
2477{ 2466{
2478 char *p; 2467 char *p;
2479 int len; 2468 int len;
2480 2469
2481 atom2str (SCHEME_A_ l, f, &p, &len); 2470 atom2str (SCHEME_A_ l, f, &p, &len);
2482 putchars (SCHEME_A_ p, len); 2471 putchars (SCHEME_A_ p, len);
2483} 2472}
2484 2473
2485/* Uses internal buffer unless string pointer is already available */ 2474/* Uses internal buffer unless string pointer is already available */
2486static void 2475ecb_cold static void
2487atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2476atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2488{ 2477{
2489 char *p; 2478 char *p;
2490 2479
2491 if (l == NIL) 2480 if (l == NIL)
… …
2624 } 2613 }
2625 else if (is_symbol (l)) 2614 else if (is_symbol (l))
2626 p = symname (l); 2615 p = symname (l);
2627 else if (is_proc (l)) 2616 else if (is_proc (l))
2628 { 2617 {
2618 p = (char *)procname (l); // ok with r7rs display, but not r7rs write
2619#if 0
2629#if USE_PRINTF 2620#if USE_PRINTF
2630 p = SCHEME_V->strbuff; 2621 p = SCHEME_V->strbuff;
2631 snprintf (p, STRBUFFSIZE, "#<%s PROCEDURE %ld>", procname (l), procnum (l)); 2622 snprintf (p, STRBUFFSIZE, " PROCEDURE %ld>", procname (l), procnum (l));
2632#else 2623#else
2633 p = "#<PROCEDURE>"; 2624 p = "#<PROCEDURE>";
2625#endif
2634#endif 2626#endif
2635 } 2627 }
2636 else if (is_macro (l)) 2628 else if (is_macro (l))
2637 p = "#<MACRO>"; 2629 p = "#<MACRO>";
2638 else if (is_closure (l)) 2630 else if (is_closure (l))
… …
2698 return car (d); 2690 return car (d);
2699 2691
2700 p = cons (car (d), cdr (d)); 2692 p = cons (car (d), cdr (d));
2701 q = p; 2693 q = p;
2702 2694
2703 while (cdr (cdr (p)) != NIL) 2695 while (cddr (p) != NIL)
2704 { 2696 {
2705 d = cons (car (p), cdr (p)); 2697 d = cons (car (p), cdr (p));
2706 2698
2707 if (cdr (cdr (p)) != NIL) 2699 if (cddr (p) != NIL)
2708 p = cdr (d); 2700 p = cdr (d);
2709 } 2701 }
2710 2702
2711 set_cdr (p, car (cdr (p))); 2703 set_cdr (p, cadr (p));
2712 return q; 2704 return q;
2713} 2705}
2714 2706
2715/* reverse list -- produce new list */ 2707/* reverse list -- produce new list */
2716static pointer 2708ecb_hot static pointer
2717reverse (SCHEME_P_ pointer a) 2709reverse (SCHEME_P_ pointer a)
2718{ 2710{
2719 /* a must be checked by gc */ 2711 /* a must be checked by gc */
2720 pointer p = NIL; 2712 pointer p = NIL;
2721 2713
… …
2724 2716
2725 return p; 2717 return p;
2726} 2718}
2727 2719
2728/* reverse list --- in-place */ 2720/* reverse list --- in-place */
2729static pointer 2721ecb_hot static pointer
2730reverse_in_place (SCHEME_P_ pointer term, pointer list) 2722reverse_in_place (SCHEME_P_ pointer term, pointer list)
2731{ 2723{
2732 pointer result = term; 2724 pointer result = term;
2733 pointer p = list; 2725 pointer p = list;
2734 2726
… …
2742 2734
2743 return result; 2735 return result;
2744} 2736}
2745 2737
2746/* append list -- produce new list (in reverse order) */ 2738/* append list -- produce new list (in reverse order) */
2747static pointer 2739ecb_hot static pointer
2748revappend (SCHEME_P_ pointer a, pointer b) 2740revappend (SCHEME_P_ pointer a, pointer b)
2749{ 2741{
2750 pointer result = a; 2742 pointer result = a;
2751 pointer p = b; 2743 pointer p = b;
2752 2744
… …
2761 2753
2762 return S_F; /* signal an error */ 2754 return S_F; /* signal an error */
2763} 2755}
2764 2756
2765/* equivalence of atoms */ 2757/* equivalence of atoms */
2766int 2758ecb_hot int
2767eqv (pointer a, pointer b) 2759eqv (pointer a, pointer b)
2768{ 2760{
2769 if (is_string (a)) 2761 if (is_string (a))
2770 { 2762 {
2771 if (is_string (b)) 2763 if (is_string (b))
… …
2865 } 2857 }
2866 else 2858 else
2867 set_car (env, immutable_cons (slot, car (env))); 2859 set_car (env, immutable_cons (slot, car (env)));
2868} 2860}
2869 2861
2870static pointer 2862ecb_hot static pointer
2871find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2863find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2872{ 2864{
2873 pointer x, y; 2865 pointer x, y;
2874 2866
2875 for (x = env; x != NIL; x = cdr (x)) 2867 for (x = env; x != NIL; x = cdr (x))
… …
2896 return NIL; 2888 return NIL;
2897} 2889}
2898 2890
2899#else /* USE_ALIST_ENV */ 2891#else /* USE_ALIST_ENV */
2900 2892
2901ecb_inline void 2893static void
2902new_frame_in_env (SCHEME_P_ pointer old_env) 2894new_frame_in_env (SCHEME_P_ pointer old_env)
2903{ 2895{
2904 SCHEME_V->envir = immutable_cons (NIL, old_env); 2896 SCHEME_V->envir = immutable_cons (NIL, old_env);
2905 setenvironment (SCHEME_V->envir); 2897 setenvironment (SCHEME_V->envir);
2906} 2898}
2907 2899
2908ecb_inline void 2900static void
2909new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value) 2901new_slot_spec_in_env (SCHEME_P_ pointer env, pointer variable, pointer value)
2910{ 2902{
2911 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2903 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2912} 2904}
2913 2905
2914static pointer 2906ecb_hot static pointer
2915find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2907find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2916{ 2908{
2917 pointer x, y; 2909 pointer x, y;
2918 2910
2919 for (x = env; x != NIL; x = cdr (x)) 2911 for (x = env; x != NIL; x = cdr (x))
… …
2933 return NIL; 2925 return NIL;
2934} 2926}
2935 2927
2936#endif /* USE_ALIST_ENV else */ 2928#endif /* USE_ALIST_ENV else */
2937 2929
2938ecb_inline void 2930static void
2939new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2931new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2940{ 2932{
2941 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 2933 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2942 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value); 2934 new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
2943} 2935}
2944 2936
2945ecb_inline void 2937static void
2946set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2938set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2947{ 2939{
2948 set_cdr (slot, value); 2940 set_cdr (slot, value);
2949} 2941}
2950 2942
2951ecb_inline pointer 2943static pointer
2952slot_value_in_env (pointer slot) 2944slot_value_in_env (pointer slot)
2953{ 2945{
2954 return cdr (slot); 2946 return cdr (slot);
2955} 2947}
2956 2948
2957/* ========== Evaluation Cycle ========== */ 2949/* ========== Evaluation Cycle ========== */
2958 2950
2959static int 2951ecb_cold static int
2960xError_1 (SCHEME_P_ const char *s, pointer a) 2952xError_1 (SCHEME_P_ const char *s, pointer a)
2961{ 2953{
2962#if USE_ERROR_HOOK
2963 pointer x;
2964 pointer hdl = SCHEME_V->ERROR_HOOK;
2965#endif
2966
2967#if USE_PRINTF 2954#if USE_PRINTF
2968#if SHOW_ERROR_LINE 2955#if SHOW_ERROR_LINE
2969 char sbuf[STRBUFFSIZE]; 2956 char sbuf[STRBUFFSIZE];
2970 2957
2971 /* make sure error is not in REPL */ 2958 /* make sure error is not in REPL */
… …
2986 } 2973 }
2987#endif 2974#endif
2988#endif 2975#endif
2989 2976
2990#if USE_ERROR_HOOK 2977#if USE_ERROR_HOOK
2991 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, hdl, 1); 2978 pointer x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->ERROR_HOOK, 1);
2992 2979
2993 if (x != NIL) 2980 if (x != NIL)
2994 { 2981 {
2995 pointer code = a 2982 pointer code = a
2996 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL) 2983 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
… …
3040 pointer code; 3027 pointer code;
3041}; 3028};
3042 3029
3043# define STACK_GROWTH 3 3030# define STACK_GROWTH 3
3044 3031
3045static void 3032ecb_hot static void
3046s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3033s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3047{ 3034{
3048 int nframes = (uintptr_t)SCHEME_V->dump; 3035 int nframes = (uintptr_t)SCHEME_V->dump;
3049 struct dump_stack_frame *next_frame; 3036 struct dump_stack_frame *next_frame;
3050 3037
… …
3063 next_frame->code = code; 3050 next_frame->code = code;
3064 3051
3065 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3052 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3066} 3053}
3067 3054
3068static int 3055static ecb_hot int
3069xs_return (SCHEME_P_ pointer a) 3056xs_return (SCHEME_P_ pointer a)
3070{ 3057{
3071 int nframes = (uintptr_t)SCHEME_V->dump; 3058 int nframes = (uintptr_t)SCHEME_V->dump;
3072 struct dump_stack_frame *frame; 3059 struct dump_stack_frame *frame;
3073 3060
… …
3084 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3071 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3085 3072
3086 return 0; 3073 return 0;
3087} 3074}
3088 3075
3089ecb_inline void 3076ecb_cold void
3090dump_stack_reset (SCHEME_P) 3077dump_stack_reset (SCHEME_P)
3091{ 3078{
3092 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */ 3079 /* in this implementation, SCHEME_V->dump is the number of frames on the stack */
3093 SCHEME_V->dump = (pointer)+0; 3080 SCHEME_V->dump = (pointer)+0;
3094} 3081}
3095 3082
3096ecb_inline void 3083ecb_cold void
3097dump_stack_initialize (SCHEME_P) 3084dump_stack_initialize (SCHEME_P)
3098{ 3085{
3099 SCHEME_V->dump_size = 0; 3086 SCHEME_V->dump_size = 0;
3100 SCHEME_V->dump_base = 0; 3087 SCHEME_V->dump_base = 0;
3101 dump_stack_reset (SCHEME_A); 3088 dump_stack_reset (SCHEME_A);
3102} 3089}
3103 3090
3104static void 3091ecb_cold static void
3105dump_stack_free (SCHEME_P) 3092dump_stack_free (SCHEME_P)
3106{ 3093{
3107 free (SCHEME_V->dump_base); 3094 free (SCHEME_V->dump_base);
3108 SCHEME_V->dump_base = 0; 3095 SCHEME_V->dump_base = 0;
3109 SCHEME_V->dump = (pointer)0; 3096 SCHEME_V->dump = (pointer)0;
3110 SCHEME_V->dump_size = 0; 3097 SCHEME_V->dump_size = 0;
3111} 3098}
3112 3099
3113static void 3100ecb_cold static void
3114dump_stack_mark (SCHEME_P) 3101dump_stack_mark (SCHEME_P)
3115{ 3102{
3116 int nframes = (uintptr_t)SCHEME_V->dump; 3103 int nframes = (uintptr_t)SCHEME_V->dump;
3117 int i; 3104 int i;
3118 3105
… …
3124 mark (frame->envir); 3111 mark (frame->envir);
3125 mark (frame->code); 3112 mark (frame->code);
3126 } 3113 }
3127} 3114}
3128 3115
3129static pointer 3116ecb_cold static pointer
3130ss_get_cont (SCHEME_P) 3117ss_get_cont (SCHEME_P)
3131{ 3118{
3132 int nframes = (uintptr_t)SCHEME_V->dump; 3119 int nframes = (uintptr_t)SCHEME_V->dump;
3133 int i; 3120 int i;
3134 3121
… …
3146 } 3133 }
3147 3134
3148 return cont; 3135 return cont;
3149} 3136}
3150 3137
3151static void 3138ecb_cold static void
3152ss_set_cont (SCHEME_P_ pointer cont) 3139ss_set_cont (SCHEME_P_ pointer cont)
3153{ 3140{
3154 int i = 0; 3141 int i = 0;
3155 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3142 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3156 3143
… …
3168 SCHEME_V->dump = (pointer)(uintptr_t)i; 3155 SCHEME_V->dump = (pointer)(uintptr_t)i;
3169} 3156}
3170 3157
3171#else 3158#else
3172 3159
3173ecb_inline void 3160ecb_cold void
3174dump_stack_reset (SCHEME_P) 3161dump_stack_reset (SCHEME_P)
3175{ 3162{
3176 SCHEME_V->dump = NIL; 3163 SCHEME_V->dump = NIL;
3177} 3164}
3178 3165
3179ecb_inline void 3166ecb_cold void
3180dump_stack_initialize (SCHEME_P) 3167dump_stack_initialize (SCHEME_P)
3181{ 3168{
3182 dump_stack_reset (SCHEME_A); 3169 dump_stack_reset (SCHEME_A);
3183} 3170}
3184 3171
3185static void 3172ecb_cold static void
3186dump_stack_free (SCHEME_P) 3173dump_stack_free (SCHEME_P)
3187{ 3174{
3188 SCHEME_V->dump = NIL; 3175 SCHEME_V->dump = NIL;
3189} 3176}
3190 3177
3191static int 3178ecb_hot static int
3192xs_return (SCHEME_P_ pointer a) 3179xs_return (SCHEME_P_ pointer a)
3193{ 3180{
3194 pointer dump = SCHEME_V->dump; 3181 pointer dump = SCHEME_V->dump;
3195 3182
3196 SCHEME_V->value = a; 3183 SCHEME_V->value = a;
… …
3206 SCHEME_V->dump = dump; 3193 SCHEME_V->dump = dump;
3207 3194
3208 return 0; 3195 return 0;
3209} 3196}
3210 3197
3211static void 3198ecb_hot static void
3212s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3199s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3213{ 3200{
3214 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3201 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3215 cons (args, 3202 cons (args,
3216 cons (SCHEME_V->envir, 3203 cons (SCHEME_V->envir,
3217 cons (code, 3204 cons (code,
3218 SCHEME_V->dump)))); 3205 SCHEME_V->dump))));
3219} 3206}
3220 3207
3221static void 3208ecb_cold static void
3222dump_stack_mark (SCHEME_P) 3209dump_stack_mark (SCHEME_P)
3223{ 3210{
3224 mark (SCHEME_V->dump); 3211 mark (SCHEME_V->dump);
3225} 3212}
3226 3213
3227static pointer 3214ecb_cold static pointer
3228ss_get_cont (SCHEME_P) 3215ss_get_cont (SCHEME_P)
3229{ 3216{
3230 return SCHEME_V->dump; 3217 return SCHEME_V->dump;
3231} 3218}
3232 3219
3233static void 3220ecb_cold static void
3234ss_set_cont (SCHEME_P_ pointer cont) 3221ss_set_cont (SCHEME_P_ pointer cont)
3235{ 3222{
3236 SCHEME_V->dump = cont; 3223 SCHEME_V->dump = cont;
3237} 3224}
3238 3225
3239#endif 3226#endif
3240 3227
3241#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3228#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3242 3229
3243#if EXPERIMENT 3230#if EXPERIMENT
3231
3244static int 3232static int
3245debug (SCHEME_P_ int indent, pointer x) 3233dtree (SCHEME_P_ int indent, pointer x)
3246{ 3234{
3247 int c; 3235 int c;
3248 3236
3249 if (is_syntax (x)) 3237 if (is_syntax (x))
3250 { 3238 {
… …
3268 printf ("%*sS<%s>\n", indent, "", symname (x)); 3256 printf ("%*sS<%s>\n", indent, "", symname (x));
3269 return 24+8; 3257 return 24+8;
3270 3258
3271 case T_CLOSURE: 3259 case T_CLOSURE:
3272 printf ("%*sS<%s>\n", indent, "", "closure"); 3260 printf ("%*sS<%s>\n", indent, "", "closure");
3273 debug (SCHEME_A_ indent + 3, cdr(x)); 3261 dtree (SCHEME_A_ indent + 3, cdr(x));
3274 return 32 + debug (SCHEME_A_ indent + 3, car (x)); 3262 return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3275 3263
3276 case T_PAIR: 3264 case T_PAIR:
3277 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); 3265 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3278 c = debug (SCHEME_A_ indent + 3, car (x)); 3266 c = dtree (SCHEME_A_ indent + 3, car (x));
3279 c += debug (SCHEME_A_ indent + 3, cdr (x)); 3267 c += dtree (SCHEME_A_ indent + 3, cdr (x));
3280 return c + 1; 3268 return c + 1;
3281 3269
3282 case T_PORT: 3270 case T_PORT:
3283 printf ("%*sS<%s>\n", indent, "", "port"); 3271 printf ("%*sS<%s>\n", indent, "", "port");
3284 return 24+8; 3272 return 24+8;
… …
3287 printf ("%*sS<%s>\n", indent, "", "vector"); 3275 printf ("%*sS<%s>\n", indent, "", "vector");
3288 return 24+8; 3276 return 24+8;
3289 3277
3290 case T_ENVIRONMENT: 3278 case T_ENVIRONMENT:
3291 printf ("%*sS<%s>\n", indent, "", "environment"); 3279 printf ("%*sS<%s>\n", indent, "", "environment");
3292 return 0 + debug (SCHEME_A_ indent + 3, car (x)); 3280 return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3293 3281
3294 default: 3282 default:
3295 printf ("unhandled type %d\n", type (x)); 3283 printf ("unhandled type %d\n", type (x));
3296 break; 3284 break;
3297 } 3285 }
3298} 3286}
3299#endif
3300 3287
3288#define DUMP(t) do { printf ("DUMP %s:%d\n", __FILE__, __LINE__); dtree (SCHEME_A_ 0, (t)); } while (0)
3289
3290typedef void *stream[1];
3291
3292#define stream_init() { 0 }
3293#define stream_data(s) ((char *)(s)[0] + sizeof (uint32_t) * 2)
3294#define stream_size(s) (((uint32_t *)(s)[0])[0] - sizeof (uint32_t) * 2)
3295#define stream_free(s) free (s[0])
3296
3297ecb_cold static void
3298stream_put (stream s, uint8_t byte)
3299{
3300 uint32_t *sp = *s;
3301 uint32_t size = sizeof (uint32_t) * 2;
3302 uint32_t offs = size;
3303
3304 if (ecb_expect_true (sp))
3305 {
3306 offs = sp[0];
3307 size = sp[1];
3308 }
3309
3310 if (ecb_expect_false (offs == size))
3311 {
3312 size *= 2;
3313 sp = realloc (sp, size);
3314 *s = sp;
3315 sp[1] = size;
3316
3317 }
3318
3319 ((uint8_t *)sp)[offs++] = byte;
3320 sp[0] = offs;
3321}
3322
3323ecb_cold static void
3324stream_put_v (stream s, uint32_t v)
3325{
3326 while (v > 0x7f)
3327 {
3328 stream_put (s, v | 0x80);
3329 v >>= 7;
3330 }
3331
3332 stream_put (s, v);
3333}
3334
3335ecb_cold static void
3336stream_put_tv (stream s, int bop, uint32_t v)
3337{
3338 printf ("put tv %d %d\n", bop, v);//D
3339 stream_put (s, bop);
3340 stream_put_v (s, v);
3341}
3342
3343ecb_cold static void
3344stream_put_stream (stream s, stream o)
3345{
3346 uint32_t i;
3347
3348 for (i = 0; i < stream_size (o); ++i)
3349 stream_put (s, stream_data (o)[i]);
3350
3351 stream_free (o);
3352}
3353
3354ecb_cold static uint32_t
3355cell_id (SCHEME_P_ pointer x)
3356{
3357 struct cell *p = CELL (x);
3358 int i;
3359
3360 for (i = SCHEME_V->last_cell_seg; i >= 0; --i)
3361 if (SCHEME_V->cell_seg[i] <= p && p < SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize[i])
3362 return i | ((p - SCHEME_V->cell_seg[i]) << CELL_NSEGMENT_LOG);
3363
3364 abort ();
3365}
3366
3367// calculates a (preferably small) integer that makes it possible to find
3368// the symbol again. if pointers were offsets into a memory area... until
3369// then, we return segment number in the low bits, and offset in the high
3370// bits.
3371// also, this function must never return 0.
3372ecb_cold static uint32_t
3373symbol_id (SCHEME_P_ pointer sym)
3374{
3375 return cell_id (SCHEME_A_ sym);
3376}
3377
3378enum byteop
3379{
3380 BOP_NIL,
3381 BOP_INTEGER,
3382 BOP_SYMBOL,
3383 BOP_DATUM,
3384 BOP_LIST_BEG,
3385 BOP_LIST_END,
3386 BOP_IF,
3387 BOP_AND,
3388 BOP_OR,
3389 BOP_CASE,
3390 BOP_COND,
3391 BOP_LET,
3392 BOP_LETAST,
3393 BOP_LETREC,
3394 BOP_DEFINE,
3395 BOP_MACRO,
3396 BOP_SET,
3397 BOP_BEGIN,
3398 BOP_LAMBDA,
3399 BOP_DELAY,
3400 BOP_OP,
3401};
3402
3403ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
3404
3405ecb_cold static void
3406compile_list (SCHEME_P_ stream s, pointer x)
3407{
3408 // TODO: improper list
3409
3410 for (; x != NIL; x = cdr (x))
3411 {
3412 stream t = stream_init ();
3413 compile_expr (SCHEME_A_ t, car (x));
3414 stream_put_v (s, stream_size (t));
3415 stream_put_stream (s, t);
3416 }
3417
3418 stream_put_v (s, 0);
3419}
3420
3421static void
3422compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
3423{
3424 stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
3425
3426 stream_put (s, BOP_IF);
3427 compile_expr (SCHEME_A_ s, cond);
3428 stream_put_v (s, stream_size (sift));
3429 stream_put_stream (s, sift);
3430 compile_expr (SCHEME_A_ s, iff);
3431}
3432
3433typedef uint32_t stream_fixup;
3434
3435static stream_fixup
3436stream_put_fixup (stream s)
3437{
3438 stream_put (s, 0);
3439 stream_put (s, 0);
3440
3441 return stream_size (s);
3442}
3443
3444static void
3445stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target)
3446{
3447 target -= fixup;
3448 assert (target < (1 << 14));
3449 stream_data (s)[fixup - 2] = target | 0x80;
3450 stream_data (s)[fixup - 1] = target >> 7;
3451}
3452
3453static void
3454compile_and_or (SCHEME_P_ stream s, int and, pointer x)
3455{
3456 for (; cdr (x) != NIL; x = cdr (x))
3457 {
3458 stream t = stream_init ();
3459 compile_expr (SCHEME_A_ t, car (x));
3460 stream_put_v (s, stream_size (t));
3461 stream_put_stream (s, t);
3462 }
3463
3464 stream_put_v (s, 0);
3465}
3466
3467static void
3468compile_case (SCHEME_P_ stream s, pointer x)
3469{
3470 compile_expr (SCHEME_A_ s, caar (x));
3471
3472 for (;;)
3473 {
3474 x = cdr (x);
3475
3476 if (x == NIL)
3477 break;
3478
3479 compile_expr (SCHEME_A_ s, caar (x));
3480 stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
3481 stream_put_v (s, stream_size (t));
3482 stream_put_stream (s, t);
3483 }
3484
3485 stream_put_v (s, 0);
3486}
3487
3488static void
3489compile_cond (SCHEME_P_ stream s, pointer x)
3490{
3491 for ( ; x != NIL; x = cdr (x))
3492 {
3493 compile_expr (SCHEME_A_ s, caar (x));
3494 stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
3495 stream_put_v (s, stream_size (t));
3496 stream_put_stream (s, t);
3497 }
3498
3499 stream_put_v (s, 0);
3500}
3501
3301static int 3502static pointer
3503lookup (SCHEME_P_ pointer x)
3504{
3505 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, x, 1);
3506
3507 if (x != NIL)
3508 x = slot_value_in_env (x);
3509
3510 return x;
3511}
3512
3513ecb_cold static void
3514compile_expr (SCHEME_P_ stream s, pointer x)
3515{
3516 if (x == NIL)
3517 {
3518 stream_put (s, BOP_NIL);
3519 return;
3520 }
3521
3522 if (is_pair (x))
3523 {
3524 pointer head = car (x);
3525
3526 if (is_syntax (head))
3527 {
3528 int syn = syntaxnum (head);
3529 x = cdr (x);
3530
3531 switch (syntaxnum (head))
3532 {
3533 case OP_IF0: /* if */
3534 stream_put_v (s, BOP_IF);
3535 compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
3536 break;
3537
3538 case OP_OR0: /* or */
3539 stream_put_v (s, BOP_OR);
3540 compile_and_or (SCHEME_A_ s, 0, x);
3541 break;
3542
3543 case OP_AND0: /* and */
3544 stream_put_v (s, BOP_AND);
3545 compile_and_or (SCHEME_A_ s, 1, x);
3546 break;
3547
3548 case OP_CASE0: /* case */
3549 stream_put_v (s, BOP_CASE);
3550 compile_case (SCHEME_A_ s, x);
3551 break;
3552
3553 case OP_COND0: /* cond */
3554 stream_put_v (s, BOP_COND);
3555 compile_cond (SCHEME_A_ s, x);
3556 break;
3557
3558 case OP_LET0: /* let */
3559 case OP_LET0AST: /* let* */
3560 case OP_LET0REC: /* letrec */
3561 switch (syn)
3562 {
3563 case OP_LET0: stream_put (s, BOP_LET ); break;
3564 case OP_LET0AST: stream_put (s, BOP_LETAST); break;
3565 case OP_LET0REC: stream_put (s, BOP_LETREC); break;
3566 }
3567
3568 {
3569 pointer bindings = car (x);
3570 pointer body = cadr (x);
3571
3572 for (x = bindings; x != NIL; x = cdr (x))
3573 {
3574 pointer init = NIL;
3575 pointer var = car (x);
3576
3577 if (is_pair (var))
3578 {
3579 init = cdr (var);
3580 var = car (var);
3581 }
3582
3583 stream_put_v (s, symbol_id (SCHEME_A_ var));
3584 compile_expr (SCHEME_A_ s, init);
3585 }
3586
3587 stream_put_v (s, 0);
3588 compile_expr (SCHEME_A_ s, body);
3589 }
3590 break;
3591
3592 case OP_DEF0: /* define */
3593 case OP_MACRO0: /* macro */
3594 stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO);
3595 stream_put_v (s, cell_id (SCHEME_A_ car (x)));
3596 compile_expr (SCHEME_A_ s, cadr (x));
3597 break;
3598
3599 case OP_SET0: /* set! */
3600 stream_put (s, BOP_SET);
3601 stream_put_v (s, symbol_id (SCHEME_A_ car (x)));
3602 compile_expr (SCHEME_A_ s, cadr (x));
3603 break;
3604
3605 case OP_BEGIN: /* begin */
3606 stream_put (s, BOP_BEGIN);
3607 compile_list (SCHEME_A_ s, x);
3608 return;
3609
3610 case OP_QUOTE: /* quote */
3611 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3612 break;
3613
3614 case OP_DELAY: /* delay */
3615 case OP_LAMBDA: /* lambda */
3616 {
3617 pointer formals = car (x);
3618 pointer body = cadr (x);
3619
3620 stream_put (s, syn == OP_LAMBDA ? BOP_LAMBDA : BOP_DELAY);
3621
3622 for (; is_pair (formals); formals = cdr (formals))
3623 stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
3624
3625 stream_put_v (s, 0);
3626 stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals));
3627
3628 compile_expr (SCHEME_A_ s, body);
3629 }
3630 break;
3631
3632 case OP_C0STREAM:/* cons-stream */
3633 abort ();
3634 break;
3635 }
3636
3637 return;
3638 }
3639
3640 pointer m = lookup (SCHEME_A_ head);
3641
3642 if (is_macro (m))
3643 {
3644 s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
3645 SCHEME_V->code = m;
3646 SCHEME_V->args = cons (x, NIL);
3647 Eval_Cycle (SCHEME_A_ OP_APPLY);
3648 x = SCHEME_V->value;
3649 compile_expr (SCHEME_A_ s, SCHEME_V->value);
3650 return;
3651 }
3652
3653 stream_put (s, BOP_LIST_BEG);
3654
3655 for (; x != NIL; x = cdr (x))
3656 compile_expr (SCHEME_A_ s, car (x));
3657
3658 stream_put (s, BOP_LIST_END);
3659 return;
3660 }
3661
3662 switch (type (x))
3663 {
3664 case T_INTEGER:
3665 {
3666 IVALUE iv = ivalue_unchecked (x);
3667 iv = iv < 0 ? ((~(uint32_t)iv) << 1) | 1 : (uint32_t)iv << 1;
3668 stream_put_tv (s, BOP_INTEGER, iv);
3669 }
3670 return;
3671
3672 case T_SYMBOL:
3673 if (0)
3674 {
3675 // no can do without more analysis
3676 pointer m = lookup (SCHEME_A_ x);
3677
3678 if (is_proc (m))
3679 {
3680 printf ("compile proc %s %d\n", procname(m), procnum(m));
3681 stream_put_tv (s, BOP_SYMBOL, BOP_OP + procnum (m));
3682 }
3683 else
3684 stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3685 }
3686
3687 stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3688 return;
3689
3690 default:
3691 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3692 break;
3693 }
3694}
3695
3696ecb_cold static int
3697compile_closure (SCHEME_P_ pointer p)
3698{
3699 stream s = stream_init ();
3700
3701 compile_list (SCHEME_A_ s, cdar (p));
3702
3703 FILE *xxd = popen ("xxd", "we");
3704 fwrite (stream_data (s), 1, stream_size (s), xxd);
3705 fclose (xxd);
3706
3707 return stream_size (s);
3708}
3709
3710#endif
3711
3712/* syntax, eval, core, ... */
3713ecb_hot static int
3302opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3714opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3303{ 3715{
3304 pointer args = SCHEME_V->args; 3716 pointer args = SCHEME_V->args;
3305 pointer x, y; 3717 pointer x, y;
3306 3718
3307 switch (op) 3719 switch (op)
3308 { 3720 {
3309#if EXPERIMENT //D 3721#if EXPERIMENT //D
3310 case OP_DEBUG: 3722 case OP_DEBUG:
3311 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3723 {
3724 uint32_t len = compile_closure (SCHEME_A_ car (args));
3725 printf ("len = %d\n", len);
3312 printf ("\n"); 3726 printf ("\n");
3313 s_return (S_T); 3727 s_return (S_T);
3728 }
3729
3730 case OP_DEBUG2:
3731 return -1;
3314#endif 3732#endif
3733
3315 case OP_LOAD: /* load */ 3734 case OP_LOAD: /* load */
3316 if (file_interactive (SCHEME_A)) 3735 if (file_interactive (SCHEME_A))
3317 { 3736 {
3318 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n"); 3737 putstr (SCHEME_A_ "Loading ");
3319 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3738 putstr (SCHEME_A_ strvalue (car (args)));
3739 putcharacter (SCHEME_A_ '\n');
3320 } 3740 }
3321 3741
3322 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3742 if (!file_push (SCHEME_A_ strvalue (car (args))))
3323 Error_1 ("unable to open", car (args)); 3743 Error_1 ("unable to open", car (args));
3324 else 3744
3325 {
3326 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3745 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3327 s_goto (OP_T0LVL); 3746 s_goto (OP_T0LVL);
3328 }
3329 3747
3330 case OP_T0LVL: /* top level */ 3748 case OP_T0LVL: /* top level */
3331 3749
3332 /* If we reached the end of file, this loop is done. */ 3750 /* If we reached the end of file, this loop is done. */
3333 if (port (SCHEME_V->loadport)->kind & port_saw_EOF) 3751 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
… …
3349 /* If interactive, be nice to user. */ 3767 /* If interactive, be nice to user. */
3350 if (file_interactive (SCHEME_A)) 3768 if (file_interactive (SCHEME_A))
3351 { 3769 {
3352 SCHEME_V->envir = SCHEME_V->global_env; 3770 SCHEME_V->envir = SCHEME_V->global_env;
3353 dump_stack_reset (SCHEME_A); 3771 dump_stack_reset (SCHEME_A);
3354 putstr (SCHEME_A_ "\n"); 3772 putcharacter (SCHEME_A_ '\n');
3773#if EXPERIMENT
3774 system ("ps v $PPID");
3775#endif
3355 putstr (SCHEME_A_ prompt); 3776 putstr (SCHEME_A_ prompt);
3356 } 3777 }
3357 3778
3358 /* Set up another iteration of REPL */ 3779 /* Set up another iteration of REPL */
3359 SCHEME_V->nesting = 0; 3780 SCHEME_V->nesting = 0;
… …
3394 { 3815 {
3395 SCHEME_V->print_flag = 1; 3816 SCHEME_V->print_flag = 1;
3396 SCHEME_V->args = SCHEME_V->value; 3817 SCHEME_V->args = SCHEME_V->value;
3397 s_goto (OP_P0LIST); 3818 s_goto (OP_P0LIST);
3398 } 3819 }
3399 else 3820
3400 s_return (SCHEME_V->value); 3821 s_return (SCHEME_V->value);
3401 3822
3402 case OP_EVAL: /* main part of evaluation */ 3823 case OP_EVAL: /* main part of evaluation */
3403#if USE_TRACING 3824#if USE_TRACING
3404 if (SCHEME_V->tracing) 3825 if (SCHEME_V->tracing)
3405 { 3826 {
… …
3438 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3859 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3439 SCHEME_V->code = x; 3860 SCHEME_V->code = x;
3440 s_goto (OP_EVAL); 3861 s_goto (OP_EVAL);
3441 } 3862 }
3442 } 3863 }
3443 else 3864
3444 s_return (SCHEME_V->code); 3865 s_return (SCHEME_V->code);
3445 3866
3446 case OP_E0ARGS: /* eval arguments */ 3867 case OP_E0ARGS: /* eval arguments */
3447 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ 3868 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3448 { 3869 {
3449 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3870 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3450 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3871 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3451 SCHEME_V->code = SCHEME_V->value; 3872 SCHEME_V->code = SCHEME_V->value;
3452 s_goto (OP_APPLY); 3873 s_goto (OP_APPLY);
3453 } 3874 }
3454 else 3875
3455 {
3456 SCHEME_V->code = cdr (SCHEME_V->code); 3876 SCHEME_V->code = cdr (SCHEME_V->code);
3457 s_goto (OP_E1ARGS); 3877 s_goto (OP_E1ARGS);
3458 }
3459 3878
3460 case OP_E1ARGS: /* eval arguments */ 3879 case OP_E1ARGS: /* eval arguments */
3461 args = cons (SCHEME_V->value, args); 3880 args = cons (SCHEME_V->value, args);
3462 3881
3463 if (is_pair (SCHEME_V->code)) /* continue */ 3882 if (is_pair (SCHEME_V->code)) /* continue */
… …
3474 SCHEME_V->args = cdr (args); 3893 SCHEME_V->args = cdr (args);
3475 s_goto (OP_APPLY); 3894 s_goto (OP_APPLY);
3476 } 3895 }
3477 3896
3478#if USE_TRACING 3897#if USE_TRACING
3479
3480 case OP_TRACING: 3898 case OP_TRACING:
3481 { 3899 {
3482 int tr = SCHEME_V->tracing; 3900 int tr = SCHEME_V->tracing;
3483 3901
3484 SCHEME_V->tracing = ivalue_unchecked (car (args)); 3902 SCHEME_V->tracing = ivalue_unchecked (car (args));
3485 s_return (mk_integer (SCHEME_A_ tr)); 3903 s_return (mk_integer (SCHEME_A_ tr));
3486 } 3904 }
3487
3488#endif 3905#endif
3489 3906
3490 case OP_APPLY: /* apply 'code' to 'args' */ 3907 case OP_APPLY: /* apply 'code' to 'args' */
3491#if USE_TRACING 3908#if USE_TRACING
3492 if (SCHEME_V->tracing) 3909 if (SCHEME_V->tracing)
… …
3546 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3963 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3547 { 3964 {
3548 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3965 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3549 s_return (args != NIL ? car (args) : NIL); 3966 s_return (args != NIL ? car (args) : NIL);
3550 } 3967 }
3551 else 3968
3552 Error_0 ("illegal function"); 3969 Error_0 ("illegal function");
3553 3970
3554 case OP_DOMACRO: /* do macro */ 3971 case OP_DOMACRO: /* do macro */
3555 SCHEME_V->code = SCHEME_V->value; 3972 SCHEME_V->code = SCHEME_V->value;
3556 s_goto (OP_EVAL); 3973 s_goto (OP_EVAL);
3557 3974
… …
3621 else 4038 else
3622 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 4039 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3623 4040
3624 s_return (SCHEME_V->code); 4041 s_return (SCHEME_V->code);
3625 4042
3626
3627 case OP_DEFP: /* defined? */ 4043 case OP_DEFP: /* defined? */
3628 x = SCHEME_V->envir; 4044 x = SCHEME_V->envir;
3629 4045
3630 if (cdr (args) != NIL) 4046 if (cdr (args) != NIL)
3631 x = cadr (args); 4047 x = cadr (args);
… …
3649 s_return (SCHEME_V->value); 4065 s_return (SCHEME_V->value);
3650 } 4066 }
3651 else 4067 else
3652 Error_1 ("set!: unbound variable:", SCHEME_V->code); 4068 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3653 4069
3654
3655 case OP_BEGIN: /* begin */ 4070 case OP_BEGIN: /* begin */
3656 if (!is_pair (SCHEME_V->code)) 4071 if (!is_pair (SCHEME_V->code))
3657 s_return (SCHEME_V->code); 4072 s_return (SCHEME_V->code);
3658 4073
3659 if (cdr (SCHEME_V->code) != NIL) 4074 if (cdr (SCHEME_V->code) != NIL)
… …
3670 case OP_IF1: /* if */ 4085 case OP_IF1: /* if */
3671 if (is_true (SCHEME_V->value)) 4086 if (is_true (SCHEME_V->value))
3672 SCHEME_V->code = car (SCHEME_V->code); 4087 SCHEME_V->code = car (SCHEME_V->code);
3673 else 4088 else
3674 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ 4089 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
4090
3675 s_goto (OP_EVAL); 4091 s_goto (OP_EVAL);
3676 4092
3677 case OP_LET0: /* let */ 4093 case OP_LET0: /* let */
3678 SCHEME_V->args = NIL; 4094 SCHEME_V->args = NIL;
3679 SCHEME_V->value = SCHEME_V->code; 4095 SCHEME_V->value = SCHEME_V->code;
3680 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); 4096 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3681 s_goto (OP_LET1); 4097 s_goto (OP_LET1);
3682 4098
3683 case OP_LET1: /* let (calculate parameters) */ 4099 case OP_LET1: /* let (calculate parameters) */
4100 case OP_LET1REC: /* letrec (calculate parameters) */
3684 args = cons (SCHEME_V->value, args); 4101 args = cons (SCHEME_V->value, args);
3685 4102
3686 if (is_pair (SCHEME_V->code)) /* continue */ 4103 if (is_pair (SCHEME_V->code)) /* continue */
3687 { 4104 {
3688 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 4105 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)); 4106 Error_1 ("Bad syntax of binding spec in let/letrec:", car (SCHEME_V->code));
3690 4107
3691 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); 4108 s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code));
3692 SCHEME_V->code = cadar (SCHEME_V->code); 4109 SCHEME_V->code = cadar (SCHEME_V->code);
3693 SCHEME_V->args = NIL; 4110 SCHEME_V->args = NIL;
3694 s_goto (OP_EVAL); 4111 s_goto (OP_EVAL);
3695 } 4112 }
3696 else /* end */ 4113
3697 { 4114 /* end */
3698 args = reverse_in_place (SCHEME_A_ NIL, args); 4115 args = reverse_in_place (SCHEME_A_ NIL, args);
3699 SCHEME_V->code = car (args); 4116 SCHEME_V->code = car (args);
3700 SCHEME_V->args = cdr (args); 4117 SCHEME_V->args = cdr (args);
3701 s_goto (OP_LET2); 4118 s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC);
3702 }
3703 4119
3704 case OP_LET2: /* let */ 4120 case OP_LET2: /* let */
3705 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4121 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3706 4122
3707 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 4123 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 */ 4127 if (is_symbol (car (SCHEME_V->code))) /* named let */
3712 { 4128 {
3713 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 4129 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3714 { 4130 {
3715 if (!is_pair (x)) 4131 if (!is_pair (x))
3716 Error_1 ("Bad syntax of binding in let :", x); 4132 Error_1 ("Bad syntax of binding in let:", x);
3717 4133
3718 if (!is_list (SCHEME_A_ car (x))) 4134 if (!is_list (SCHEME_A_ car (x)))
3719 Error_1 ("Bad syntax of binding in let :", car (x)); 4135 Error_1 ("Bad syntax of binding in let:", car (x));
3720 4136
3721 args = cons (caar (x), args); 4137 args = cons (caar (x), args);
3722 } 4138 }
3723 4139
3724 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)), 4140 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); 4157 SCHEME_V->code = cdr (SCHEME_V->code);
3742 s_goto (OP_BEGIN); 4158 s_goto (OP_BEGIN);
3743 } 4159 }
3744 4160
3745 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code))) 4161 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)); 4162 Error_1 ("Bad syntax of binding spec in let*:", car (SCHEME_V->code));
3747 4163
3748 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code)); 4164 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
3749 SCHEME_V->code = car (cdaar (SCHEME_V->code)); 4165 SCHEME_V->code = car (cdaar (SCHEME_V->code));
3750 s_goto (OP_EVAL); 4166 s_goto (OP_EVAL);
3751 4167
… …
3762 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code); 4178 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3763 SCHEME_V->code = cadar (SCHEME_V->code); 4179 SCHEME_V->code = cadar (SCHEME_V->code);
3764 SCHEME_V->args = NIL; 4180 SCHEME_V->args = NIL;
3765 s_goto (OP_EVAL); 4181 s_goto (OP_EVAL);
3766 } 4182 }
3767 else /* end */ 4183
4184 /* end */
3768 { 4185
3769 SCHEME_V->code = args; 4186 SCHEME_V->code = args;
3770 SCHEME_V->args = NIL; 4187 SCHEME_V->args = NIL;
3771 s_goto (OP_BEGIN); 4188 s_goto (OP_BEGIN);
3772 }
3773 4189
3774 case OP_LET0REC: /* letrec */ 4190 case OP_LET0REC: /* letrec */
3775 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4191 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3776 SCHEME_V->args = NIL; 4192 SCHEME_V->args = NIL;
3777 SCHEME_V->value = SCHEME_V->code; 4193 SCHEME_V->value = SCHEME_V->code;
3778 SCHEME_V->code = car (SCHEME_V->code); 4194 SCHEME_V->code = car (SCHEME_V->code);
3779 s_goto (OP_LET1REC); 4195 s_goto (OP_LET1REC);
3780 4196
3781 case OP_LET1REC: /* letrec (calculate parameters) */ 4197 /* 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 4198
3802 case OP_LET2REC: /* letrec */ 4199 case OP_LET2REC: /* letrec */
3803 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) 4200 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)); 4201 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3805 4202
… …
3835 } 4232 }
3836 else 4233 else
3837 { 4234 {
3838 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) 4235 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3839 s_return (NIL); 4236 s_return (NIL);
3840 else 4237
3841 {
3842 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 4238 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3843 SCHEME_V->code = caar (SCHEME_V->code); 4239 SCHEME_V->code = caar (SCHEME_V->code);
3844 s_goto (OP_EVAL); 4240 s_goto (OP_EVAL);
3845 }
3846 } 4241 }
3847 4242
3848 case OP_DELAY: /* delay */ 4243 case OP_DELAY: /* delay */
3849 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 4244 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3850 set_typeflag (x, T_PROMISE); 4245 set_typeflag (x, T_PROMISE);
… …
3861 case OP_AND1: /* and */ 4256 case OP_AND1: /* and */
3862 if (is_false (SCHEME_V->value)) 4257 if (is_false (SCHEME_V->value))
3863 s_return (SCHEME_V->value); 4258 s_return (SCHEME_V->value);
3864 else if (SCHEME_V->code == NIL) 4259 else if (SCHEME_V->code == NIL)
3865 s_return (SCHEME_V->value); 4260 s_return (SCHEME_V->value);
3866 else 4261
3867 {
3868 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 4262 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3869 SCHEME_V->code = car (SCHEME_V->code); 4263 SCHEME_V->code = car (SCHEME_V->code);
3870 s_goto (OP_EVAL); 4264 s_goto (OP_EVAL);
3871 }
3872 4265
3873 case OP_OR0: /* or */ 4266 case OP_OR0: /* or */
3874 if (SCHEME_V->code == NIL) 4267 if (SCHEME_V->code == NIL)
3875 s_return (S_F); 4268 s_return (S_F);
3876 4269
… …
3881 case OP_OR1: /* or */ 4274 case OP_OR1: /* or */
3882 if (is_true (SCHEME_V->value)) 4275 if (is_true (SCHEME_V->value))
3883 s_return (SCHEME_V->value); 4276 s_return (SCHEME_V->value);
3884 else if (SCHEME_V->code == NIL) 4277 else if (SCHEME_V->code == NIL)
3885 s_return (SCHEME_V->value); 4278 s_return (SCHEME_V->value);
3886 else 4279
3887 {
3888 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 4280 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3889 SCHEME_V->code = car (SCHEME_V->code); 4281 SCHEME_V->code = car (SCHEME_V->code);
3890 s_goto (OP_EVAL); 4282 s_goto (OP_EVAL);
3891 }
3892 4283
3893 case OP_C0STREAM: /* cons-stream */ 4284 case OP_C0STREAM: /* cons-stream */
3894 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 4285 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3895 SCHEME_V->code = car (SCHEME_V->code); 4286 SCHEME_V->code = car (SCHEME_V->code);
3896 s_goto (OP_EVAL); 4287 s_goto (OP_EVAL);
… …
3961 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x)); 4352 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3962 SCHEME_V->code = caar (x); 4353 SCHEME_V->code = caar (x);
3963 s_goto (OP_EVAL); 4354 s_goto (OP_EVAL);
3964 } 4355 }
3965 } 4356 }
3966 else 4357
3967 s_return (NIL); 4358 s_return (NIL);
3968 4359
3969 case OP_CASE2: /* case */ 4360 case OP_CASE2: /* case */
3970 if (is_true (SCHEME_V->value)) 4361 if (is_true (SCHEME_V->value))
3971 s_goto (OP_BEGIN); 4362 s_goto (OP_BEGIN);
3972 else 4363
3973 s_return (NIL); 4364 s_return (NIL);
3974 4365
3975 case OP_PAPPLY: /* apply */ 4366 case OP_PAPPLY: /* apply */
3976 SCHEME_V->code = car (args); 4367 SCHEME_V->code = car (args);
3977 SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); 4368 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
3978 /*SCHEME_V->args = cadr(args); */ 4369 /*SCHEME_V->args = cadr(args); */
… …
3992 } 4383 }
3993 4384
3994 if (USE_ERROR_CHECKING) abort (); 4385 if (USE_ERROR_CHECKING) abort ();
3995} 4386}
3996 4387
3997static int 4388/* math, cxr */
4389ecb_hot static int
3998opexe_1 (SCHEME_P_ enum scheme_opcodes op) 4390opexe_1 (SCHEME_P_ enum scheme_opcodes op)
3999{ 4391{
4000 pointer args = SCHEME_V->args; 4392 pointer args = SCHEME_V->args;
4001 pointer x = car (args); 4393 pointer x = car (args);
4002 num v; 4394 num v;
… …
4483 } 4875 }
4484 4876
4485 if (USE_ERROR_CHECKING) abort (); 4877 if (USE_ERROR_CHECKING) abort ();
4486} 4878}
4487 4879
4488static int 4880/* relational ops */
4881ecb_hot static int
4489opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4882opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4490{ 4883{
4491 pointer x = SCHEME_V->args; 4884 pointer x = SCHEME_V->args;
4492 4885
4493 for (;;) 4886 for (;;)
… …
4514 } 4907 }
4515 4908
4516 s_return (S_T); 4909 s_return (S_T);
4517} 4910}
4518 4911
4519static int 4912/* predicates */
4913ecb_hot static int
4520opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4914opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4521{ 4915{
4522 pointer args = SCHEME_V->args; 4916 pointer args = SCHEME_V->args;
4523 pointer a = car (args); 4917 pointer a = car (args);
4524 pointer d = cdr (args); 4918 pointer d = cdr (args);
… …
4571 } 4965 }
4572 4966
4573 s_retbool (r); 4967 s_retbool (r);
4574} 4968}
4575 4969
4576static int 4970/* promises, list ops, ports */
4971ecb_hot static int
4577opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4972opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4578{ 4973{
4579 pointer args = SCHEME_V->args; 4974 pointer args = SCHEME_V->args;
4580 pointer a = car (args); 4975 pointer a = car (args);
4581 pointer x, y; 4976 pointer x, y;
… …
4624 else 5019 else
4625 SCHEME_V->print_flag = 0; 5020 SCHEME_V->print_flag = 0;
4626 5021
4627 s_goto (OP_P0LIST); 5022 s_goto (OP_P0LIST);
4628 5023
5024 //TODO: move to scheme
4629 case OP_NEWLINE: /* newline */ 5025 case OP_NEWLINE: /* newline */
4630 if (is_pair (args)) 5026 if (is_pair (args))
4631 { 5027 {
4632 if (a != SCHEME_V->outport) 5028 if (a != SCHEME_V->outport)
4633 { 5029 {
… …
4635 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 5031 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4636 SCHEME_V->outport = a; 5032 SCHEME_V->outport = a;
4637 } 5033 }
4638 } 5034 }
4639 5035
4640 putstr (SCHEME_A_ "\n"); 5036 putcharacter (SCHEME_A_ '\n');
4641 s_return (S_T); 5037 s_return (S_T);
4642#endif 5038#endif
4643 5039
4644 case OP_ERR0: /* error */ 5040 case OP_ERR0: /* error */
4645 SCHEME_V->retcode = -1; 5041 SCHEME_V->retcode = -1;
… …
4654 putstr (SCHEME_A_ strvalue (car (args))); 5050 putstr (SCHEME_A_ strvalue (car (args)));
4655 SCHEME_V->args = cdr (args); 5051 SCHEME_V->args = cdr (args);
4656 s_goto (OP_ERR1); 5052 s_goto (OP_ERR1);
4657 5053
4658 case OP_ERR1: /* error */ 5054 case OP_ERR1: /* error */
4659 putstr (SCHEME_A_ " "); 5055 putcharacter (SCHEME_A_ ' ');
4660 5056
4661 if (args != NIL) 5057 if (args != NIL)
4662 { 5058 {
4663 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); 5059 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4664 SCHEME_V->args = a; 5060 SCHEME_V->args = a;
4665 SCHEME_V->print_flag = 1; 5061 SCHEME_V->print_flag = 1;
4666 s_goto (OP_P0LIST); 5062 s_goto (OP_P0LIST);
4667 } 5063 }
4668 else 5064 else
4669 { 5065 {
4670 putstr (SCHEME_A_ "\n"); 5066 putcharacter (SCHEME_A_ '\n');
4671 5067
4672 if (SCHEME_V->interactive_repl) 5068 if (SCHEME_V->interactive_repl)
4673 s_goto (OP_T0LVL); 5069 s_goto (OP_T0LVL);
4674 else 5070 else
4675 return -1; 5071 return -1;
… …
4883 } 5279 }
4884 5280
4885 if (USE_ERROR_CHECKING) abort (); 5281 if (USE_ERROR_CHECKING) abort ();
4886} 5282}
4887 5283
4888static int 5284/* reading */
5285ecb_cold static int
4889opexe_5 (SCHEME_P_ enum scheme_opcodes op) 5286opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4890{ 5287{
4891 pointer args = SCHEME_V->args; 5288 pointer args = SCHEME_V->args;
4892 pointer x; 5289 pointer x;
4893 5290
… …
4972 case OP_RDSEXPR: 5369 case OP_RDSEXPR:
4973 switch (SCHEME_V->tok) 5370 switch (SCHEME_V->tok)
4974 { 5371 {
4975 case TOK_EOF: 5372 case TOK_EOF:
4976 s_return (S_EOF); 5373 s_return (S_EOF);
4977 /* NOTREACHED */
4978 5374
4979 case TOK_VEC: 5375 case TOK_VEC:
4980 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL); 5376 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
4981 /* fall through */ 5377 /* fall through */
4982 5378
… …
4985 5381
4986 if (SCHEME_V->tok == TOK_RPAREN) 5382 if (SCHEME_V->tok == TOK_RPAREN)
4987 s_return (NIL); 5383 s_return (NIL);
4988 else if (SCHEME_V->tok == TOK_DOT) 5384 else if (SCHEME_V->tok == TOK_DOT)
4989 Error_0 ("syntax error: illegal dot expression"); 5385 Error_0 ("syntax error: illegal dot expression");
4990 else 5386
4991 {
4992 SCHEME_V->nesting_stack[SCHEME_V->file_i]++; 5387 SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
4993 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL); 5388 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
4994 s_goto (OP_RDSEXPR); 5389 s_goto (OP_RDSEXPR);
4995 }
4996 5390
4997 case TOK_QUOTE: 5391 case TOK_QUOTE:
4998 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL); 5392 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
4999 SCHEME_V->tok = token (SCHEME_A); 5393 SCHEME_V->tok = token (SCHEME_A);
5000 s_goto (OP_RDSEXPR); 5394 s_goto (OP_RDSEXPR);
… …
5006 { 5400 {
5007 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL); 5401 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5008 SCHEME_V->tok = TOK_LPAREN; 5402 SCHEME_V->tok = TOK_LPAREN;
5009 s_goto (OP_RDSEXPR); 5403 s_goto (OP_RDSEXPR);
5010 } 5404 }
5011 else 5405
5012 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); 5406 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5013
5014 s_goto (OP_RDSEXPR); 5407 s_goto (OP_RDSEXPR);
5015 5408
5016 case TOK_COMMA: 5409 case TOK_COMMA:
5017 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL); 5410 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
5018 SCHEME_V->tok = token (SCHEME_A); 5411 SCHEME_V->tok = token (SCHEME_A);
… …
5029 case TOK_DOTATOM: 5422 case TOK_DOTATOM:
5030 SCHEME_V->strbuff[0] = '.'; 5423 SCHEME_V->strbuff[0] = '.';
5031 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); 5424 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5032 5425
5033 case TOK_STRATOM: 5426 case TOK_STRATOM:
5427 //TODO: haven't checked whether the garbage collector could interfere and free x
5428 gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded
5034 x = readstrexp (SCHEME_A_ '|'); 5429 x = readstrexp (SCHEME_A_ '|');
5035 //TODO: haven't checked whether the garbage collector could interfere
5036 s_return (mk_atom (SCHEME_A_ strvalue (x))); 5430 s_return (mk_atom (SCHEME_A_ strvalue (x)));
5037 5431
5038 case TOK_DQUOTE: 5432 case TOK_DQUOTE:
5039 x = readstrexp (SCHEME_A_ '"'); 5433 x = readstrexp (SCHEME_A_ '"');
5040 5434
… …
5048 { 5442 {
5049 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1); 5443 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);
5050 5444
5051 if (f == NIL) 5445 if (f == NIL)
5052 Error_0 ("undefined sharp expression"); 5446 Error_0 ("undefined sharp expression");
5053 else 5447
5054 {
5055 SCHEME_V->code = cons (slot_value_in_env (f), NIL); 5448 SCHEME_V->code = cons (slot_value_in_env (f), NIL);
5056 s_goto (OP_EVAL); 5449 s_goto (OP_EVAL);
5057 }
5058 } 5450 }
5059 5451
5060 case TOK_SHARP_CONST: 5452 case TOK_SHARP_CONST:
5061 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL) 5453 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5062 Error_0 ("undefined sharp expression"); 5454 Error_0 ("undefined sharp expression");
5063 else 5455
5064 s_return (x); 5456 s_return (x);
5065 5457
5066 default: 5458 default:
5067 Error_0 ("syntax error: illegal token"); 5459 Error_0 ("syntax error: illegal token");
5068 } 5460 }
5069 5461
… …
5162 pointer b = cdr (args); 5554 pointer b = cdr (args);
5163 int ok_abbr = ok_abbrev (b); 5555 int ok_abbr = ok_abbrev (b);
5164 SCHEME_V->args = car (b); 5556 SCHEME_V->args = car (b);
5165 5557
5166 if (a == SCHEME_V->QUOTE && ok_abbr) 5558 if (a == SCHEME_V->QUOTE && ok_abbr)
5167 putstr (SCHEME_A_ "'"); 5559 putcharacter (SCHEME_A_ '\'');
5168 else if (a == SCHEME_V->QQUOTE && ok_abbr) 5560 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5169 putstr (SCHEME_A_ "`"); 5561 putcharacter (SCHEME_A_ '`');
5170 else if (a == SCHEME_V->UNQUOTE && ok_abbr) 5562 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5171 putstr (SCHEME_A_ ","); 5563 putcharacter (SCHEME_A_ ',');
5172 else if (a == SCHEME_V->UNQUOTESP && ok_abbr) 5564 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5173 putstr (SCHEME_A_ ",@"); 5565 putstr (SCHEME_A_ ",@");
5174 else 5566 else
5175 { 5567 {
5176 putstr (SCHEME_A_ "("); 5568 putcharacter (SCHEME_A_ '(');
5177 s_save (SCHEME_A_ OP_P1LIST, b, NIL); 5569 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5178 SCHEME_V->args = a; 5570 SCHEME_V->args = a;
5179 } 5571 }
5180 5572
5181 s_goto (OP_P0LIST); 5573 s_goto (OP_P0LIST);
… …
5183 5575
5184 case OP_P1LIST: 5576 case OP_P1LIST:
5185 if (is_pair (args)) 5577 if (is_pair (args))
5186 { 5578 {
5187 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); 5579 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5188 putstr (SCHEME_A_ " "); 5580 putcharacter (SCHEME_A_ ' ');
5189 SCHEME_V->args = car (args); 5581 SCHEME_V->args = car (args);
5190 s_goto (OP_P0LIST); 5582 s_goto (OP_P0LIST);
5191 } 5583 }
5192 else if (is_vector (args)) 5584 else if (is_vector (args))
5193 { 5585 {
… …
5201 { 5593 {
5202 putstr (SCHEME_A_ " . "); 5594 putstr (SCHEME_A_ " . ");
5203 printatom (SCHEME_A_ args, SCHEME_V->print_flag); 5595 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5204 } 5596 }
5205 5597
5206 putstr (SCHEME_A_ ")"); 5598 putcharacter (SCHEME_A_ ')');
5207 s_return (S_T); 5599 s_return (S_T);
5208 } 5600 }
5209 5601
5210 case OP_PVECFROM: 5602 case OP_PVECFROM:
5211 { 5603 {
5212 int i = ivalue_unchecked (cdr (args)); 5604 IVALUE i = ivalue_unchecked (cdr (args));
5213 pointer vec = car (args); 5605 pointer vec = car (args);
5214 int len = veclength (vec); 5606 uint32_t len = veclength (vec);
5215 5607
5216 if (i == len) 5608 if (i == len)
5217 { 5609 {
5218 putstr (SCHEME_A_ ")"); 5610 putcharacter (SCHEME_A_ ')');
5219 s_return (S_T); 5611 s_return (S_T);
5220 } 5612 }
5221 else 5613 else
5222 { 5614 {
5223 pointer elem = vector_get (vec, i); 5615 pointer elem = vector_get (vec, i);
5224 5616
5225 ivalue_unchecked (cdr (args)) = i + 1; 5617 set_cdr (args, mk_integer (SCHEME_A_ i + 1));
5226 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5618 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5227 SCHEME_V->args = elem; 5619 SCHEME_V->args = elem;
5228 5620
5229 if (i > 0) 5621 if (i > 0)
5230 putstr (SCHEME_A_ " "); 5622 putcharacter (SCHEME_A_ ' ');
5231 5623
5232 s_goto (OP_P0LIST); 5624 s_goto (OP_P0LIST);
5233 } 5625 }
5234 } 5626 }
5235 } 5627 }
5236 5628
5237 if (USE_ERROR_CHECKING) abort (); 5629 if (USE_ERROR_CHECKING) abort ();
5238} 5630}
5239 5631
5240static int 5632/* list ops */
5633ecb_hot static int
5241opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5634opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5242{ 5635{
5243 pointer args = SCHEME_V->args; 5636 pointer args = SCHEME_V->args;
5244 pointer a = car (args); 5637 pointer a = car (args);
5245 pointer x, y; 5638 pointer x, y;
… …
5268 break; 5661 break;
5269 } 5662 }
5270 5663
5271 if (is_pair (y)) 5664 if (is_pair (y))
5272 s_return (car (y)); 5665 s_return (car (y));
5273 else 5666
5274 s_return (S_F); 5667 s_return (S_F);
5275
5276 5668
5277 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5669 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5278 SCHEME_V->args = a; 5670 SCHEME_V->args = a;
5279 5671
5280 if (SCHEME_V->args == NIL) 5672 if (SCHEME_V->args == NIL)
5281 s_return (S_F); 5673 s_return (S_F);
5282 else if (is_closure (SCHEME_V->args)) 5674 else if (is_closure (SCHEME_V->args) || is_macro (SCHEME_V->args))
5283 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5675 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5284 else if (is_macro (SCHEME_V->args)) 5676
5285 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5286 else
5287 s_return (S_F); 5677 s_return (S_F);
5288 5678
5289 case OP_CLOSUREP: /* closure? */ 5679 case OP_CLOSUREP: /* closure? */
5290 /* 5680 /*
5291 * Note, macro object is also a closure. 5681 * Note, macro object is also a closure.
5292 * Therefore, (closure? <#MACRO>) ==> #t 5682 * Therefore, (closure? <#MACRO>) ==> #t
… …
5303 5693
5304/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5694/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5305typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); 5695typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5306 5696
5307typedef int (*test_predicate)(pointer); 5697typedef int (*test_predicate)(pointer);
5308static int 5698
5699ecb_hot static int
5309tst_any (pointer p) 5700tst_any (pointer p)
5310{ 5701{
5311 return 1; 5702 return 1;
5312} 5703}
5313 5704
5314static int 5705ecb_hot static int
5315tst_inonneg (pointer p) 5706tst_inonneg (pointer p)
5316{ 5707{
5317 return is_integer (p) && ivalue_unchecked (p) >= 0; 5708 return is_integer (p) && ivalue_unchecked (p) >= 0;
5318} 5709}
5319 5710
5320static int 5711ecb_hot static int
5321tst_is_list (SCHEME_P_ pointer p) 5712tst_is_list (SCHEME_P_ pointer p)
5322{ 5713{
5323 return p == NIL || is_pair (p); 5714 return p == NIL || is_pair (p);
5324} 5715}
5325 5716
… …
5368#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" 5759#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5369#include "opdefines.h" 5760#include "opdefines.h"
5370#undef OP_DEF 5761#undef OP_DEF
5371; 5762;
5372 5763
5373static const char * 5764ecb_cold static const char *
5374opname (int idx) 5765opname (int idx)
5375{ 5766{
5376 const char *name = opnames; 5767 const char *name = opnames;
5377 5768
5378 /* should do this at compile time, but would require external program, right? */ 5769 /* should do this at compile time, but would require external program, right? */
… …
5380 name += strlen (name) + 1; 5771 name += strlen (name) + 1;
5381 5772
5382 return *name ? name : "ILLEGAL"; 5773 return *name ? name : "ILLEGAL";
5383} 5774}
5384 5775
5385static const char * 5776ecb_cold static const char *
5386procname (pointer x) 5777procname (pointer x)
5387{ 5778{
5388 return opname (procnum (x)); 5779 return opname (procnum (x));
5389} 5780}
5390 5781
… …
5410#undef OP_DEF 5801#undef OP_DEF
5411 {0} 5802 {0}
5412}; 5803};
5413 5804
5414/* kernel of this interpreter */ 5805/* kernel of this interpreter */
5415static void ecb_hot 5806ecb_hot static void
5416Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5807Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5417{ 5808{
5418 SCHEME_V->op = op; 5809 SCHEME_V->op = op;
5419 5810
5420 for (;;) 5811 for (;;)
… …
5511 } 5902 }
5512} 5903}
5513 5904
5514/* ========== Initialization of internal keywords ========== */ 5905/* ========== Initialization of internal keywords ========== */
5515 5906
5516static void 5907ecb_cold static void
5517assign_syntax (SCHEME_P_ const char *name) 5908assign_syntax (SCHEME_P_ const char *name)
5518{ 5909{
5519 pointer x = oblist_add_by_name (SCHEME_A_ name); 5910 pointer x = oblist_add_by_name (SCHEME_A_ name);
5520 set_typeflag (x, typeflag (x) | T_SYNTAX); 5911 set_typeflag (x, typeflag (x) | T_SYNTAX);
5521} 5912}
5522 5913
5523static void 5914ecb_cold static void
5524assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5915assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5525{ 5916{
5526 pointer x = mk_symbol (SCHEME_A_ name); 5917 pointer x = mk_symbol (SCHEME_A_ name);
5527 pointer y = mk_proc (SCHEME_A_ op); 5918 pointer y = mk_proc (SCHEME_A_ op);
5528 new_slot_in_env (SCHEME_A_ x, y); 5919 new_slot_in_env (SCHEME_A_ x, y);
… …
5531static pointer 5922static pointer
5532mk_proc (SCHEME_P_ enum scheme_opcodes op) 5923mk_proc (SCHEME_P_ enum scheme_opcodes op)
5533{ 5924{
5534 pointer y = get_cell (SCHEME_A_ NIL, NIL); 5925 pointer y = get_cell (SCHEME_A_ NIL, NIL);
5535 set_typeflag (y, (T_PROC | T_ATOM)); 5926 set_typeflag (y, (T_PROC | T_ATOM));
5536 ivalue_unchecked (y) = op; 5927 set_ivalue (y, op);
5537 return y; 5928 return y;
5538} 5929}
5539 5930
5540/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5931/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5541static int 5932ecb_hot static int
5542syntaxnum (pointer p) 5933syntaxnum (pointer p)
5543{ 5934{
5544 const char *s = strvalue (p); 5935 const char *s = strvalue (p);
5545 5936
5546 switch (strlength (p)) 5937 switch (strlength (p))
… …
5625 6016
5626ecb_cold int 6017ecb_cold int
5627scheme_init (SCHEME_P) 6018scheme_init (SCHEME_P)
5628{ 6019{
5629 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 6020 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5630 pointer x;
5631 6021
5632 /* this memset is not strictly correct, as we assume (intcache) 6022 /* this memset is not strictly correct, as we assume (intcache)
5633 * that memset 0 will also set pointers to 0, but memset does 6023 * that memset 0 will also set pointers to 0, but memset does
5634 * of course not guarantee that. screw such systems. 6024 * of course not guarantee that. screw such systems.
5635 */ 6025 */
… …
5663#endif 6053#endif
5664 } 6054 }
5665 6055
5666 SCHEME_V->gc_verbose = 0; 6056 SCHEME_V->gc_verbose = 0;
5667 dump_stack_initialize (SCHEME_A); 6057 dump_stack_initialize (SCHEME_A);
5668 SCHEME_V->code = NIL; 6058 SCHEME_V->code = NIL;
5669 SCHEME_V->args = NIL; 6059 SCHEME_V->args = NIL;
5670 SCHEME_V->envir = NIL; 6060 SCHEME_V->envir = NIL;
6061 SCHEME_V->value = NIL;
5671 SCHEME_V->tracing = 0; 6062 SCHEME_V->tracing = 0;
5672 6063
5673 /* init NIL */ 6064 /* init NIL */
5674 set_typeflag (NIL, T_ATOM | T_MARK); 6065 set_typeflag (NIL, T_SPECIAL | T_ATOM);
5675 set_car (NIL, NIL); 6066 set_car (NIL, NIL);
5676 set_cdr (NIL, NIL); 6067 set_cdr (NIL, NIL);
5677 /* init T */ 6068 /* init T */
5678 set_typeflag (S_T, T_ATOM | T_MARK); 6069 set_typeflag (S_T, T_SPECIAL | T_ATOM);
5679 set_car (S_T, S_T); 6070 set_car (S_T, S_T);
5680 set_cdr (S_T, S_T); 6071 set_cdr (S_T, S_T);
5681 /* init F */ 6072 /* init F */
5682 set_typeflag (S_F, T_ATOM | T_MARK); 6073 set_typeflag (S_F, T_SPECIAL | T_ATOM);
5683 set_car (S_F, S_F); 6074 set_car (S_F, S_F);
5684 set_cdr (S_F, S_F); 6075 set_cdr (S_F, S_F);
5685 /* init EOF_OBJ */ 6076 /* init EOF_OBJ */
5686 set_typeflag (S_EOF, T_ATOM | T_MARK); 6077 set_typeflag (S_EOF, T_SPECIAL | T_ATOM);
5687 set_car (S_EOF, S_EOF); 6078 set_car (S_EOF, S_EOF);
5688 set_cdr (S_EOF, S_EOF); 6079 set_cdr (S_EOF, S_EOF);
5689 /* init sink */ 6080 /* init sink */
5690 set_typeflag (S_SINK, T_PAIR | T_MARK); 6081 set_typeflag (S_SINK, T_PAIR);
5691 set_car (S_SINK, NIL); 6082 set_car (S_SINK, NIL);
5692 6083
5693 /* init c_nest */ 6084 /* init c_nest */
5694 SCHEME_V->c_nest = NIL; 6085 SCHEME_V->c_nest = NIL;
5695 6086
5696 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 6087 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5697 /* init global_env */ 6088 /* init global_env */
5698 new_frame_in_env (SCHEME_A_ NIL); 6089 new_frame_in_env (SCHEME_A_ NIL);
5699 SCHEME_V->global_env = SCHEME_V->envir; 6090 SCHEME_V->global_env = SCHEME_V->envir;
5700 /* init else */ 6091 /* init else */
5701 x = mk_symbol (SCHEME_A_ "else"); 6092 new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), S_T);
5702 new_slot_in_env (SCHEME_A_ x, S_T);
5703 6093
5704 { 6094 {
5705 static const char *syntax_names[] = { 6095 static const char *syntax_names[] = {
5706 "lambda", "quote", "define", "if", "begin", "set!", 6096 "lambda", "quote", "define", "if", "begin", "set!",
5707 "let", "let*", "letrec", "cond", "delay", "and", 6097 "let", "let*", "letrec", "cond", "delay", "and",
… …
5731 6121
5732 return !SCHEME_V->no_memory; 6122 return !SCHEME_V->no_memory;
5733} 6123}
5734 6124
5735#if USE_PORTS 6125#if USE_PORTS
5736void 6126ecb_cold void
5737scheme_set_input_port_file (SCHEME_P_ int fin) 6127scheme_set_input_port_file (SCHEME_P_ int fin)
5738{ 6128{
5739 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 6129 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5740} 6130}
5741 6131
5742void 6132ecb_cold void
5743scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 6133scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5744{ 6134{
5745 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 6135 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5746} 6136}
5747 6137
5748void 6138ecb_cold void
5749scheme_set_output_port_file (SCHEME_P_ int fout) 6139scheme_set_output_port_file (SCHEME_P_ int fout)
5750{ 6140{
5751 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 6141 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5752} 6142}
5753 6143
5754void 6144ecb_cold void
5755scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 6145scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5756{ 6146{
5757 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 6147 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5758} 6148}
5759#endif 6149#endif
5760 6150
5761void 6151ecb_cold void
5762scheme_set_external_data (SCHEME_P_ void *p) 6152scheme_set_external_data (SCHEME_P_ void *p)
5763{ 6153{
5764 SCHEME_V->ext_data = p; 6154 SCHEME_V->ext_data = p;
5765} 6155}
5766 6156
… …
5798 SCHEME_V->loadport = NIL; 6188 SCHEME_V->loadport = NIL;
5799 SCHEME_V->gc_verbose = 0; 6189 SCHEME_V->gc_verbose = 0;
5800 gc (SCHEME_A_ NIL, NIL); 6190 gc (SCHEME_A_ NIL, NIL);
5801 6191
5802 for (i = 0; i <= SCHEME_V->last_cell_seg; i++) 6192 for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5803 free (SCHEME_V->alloc_seg[i]); 6193 free (SCHEME_V->cell_seg[i]);
5804 6194
5805#if SHOW_ERROR_LINE 6195#if SHOW_ERROR_LINE
5806 for (i = 0; i <= SCHEME_V->file_i; i++) 6196 for (i = 0; i <= SCHEME_V->file_i; i++)
5807 {
5808 if (SCHEME_V->load_stack[i].kind & port_file) 6197 if (SCHEME_V->load_stack[i].kind & port_file)
5809 { 6198 {
5810 fname = SCHEME_V->load_stack[i].rep.stdio.filename; 6199 fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5811 6200
5812 if (fname) 6201 if (fname)
5813 free (fname); 6202 free (fname);
5814 } 6203 }
5815 }
5816#endif 6204#endif
5817} 6205}
5818 6206
5819void 6207ecb_cold void
5820scheme_load_file (SCHEME_P_ int fin) 6208scheme_load_file (SCHEME_P_ int fin)
5821{ 6209{
5822 scheme_load_named_file (SCHEME_A_ fin, 0); 6210 scheme_load_named_file (SCHEME_A_ fin, 0);
5823} 6211}
5824 6212
5825void 6213ecb_cold void
5826scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 6214scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5827{ 6215{
5828 dump_stack_reset (SCHEME_A); 6216 dump_stack_reset (SCHEME_A);
5829 SCHEME_V->envir = SCHEME_V->global_env; 6217 SCHEME_V->envir = SCHEME_V->global_env;
5830 SCHEME_V->file_i = 0; 6218 SCHEME_V->file_i = 0;
5831 SCHEME_V->load_stack[0].unget = -1; 6219 SCHEME_V->load_stack[0].unget = -1;
5832 SCHEME_V->load_stack[0].kind = port_input | port_file; 6220 SCHEME_V->load_stack[0].kind = port_input | port_file;
5833 SCHEME_V->load_stack[0].rep.stdio.file = fin; 6221 SCHEME_V->load_stack[0].rep.stdio.file = fin;
5834#if USE_PORTS
5835 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 6222 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5836#endif
5837 SCHEME_V->retcode = 0; 6223 SCHEME_V->retcode = 0;
5838 6224
5839#if USE_PORTS
5840 if (fin == STDIN_FILENO) 6225 if (fin == STDIN_FILENO)
5841 SCHEME_V->interactive_repl = 1; 6226 SCHEME_V->interactive_repl = 1;
5842#endif
5843 6227
5844#if USE_PORTS 6228#if USE_PORTS
5845#if SHOW_ERROR_LINE 6229#if SHOW_ERROR_LINE
5846 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0; 6230 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5847 6231
… …
5851#endif 6235#endif
5852 6236
5853 SCHEME_V->inport = SCHEME_V->loadport; 6237 SCHEME_V->inport = SCHEME_V->loadport;
5854 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6238 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5855 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6239 Eval_Cycle (SCHEME_A_ OP_T0LVL);
6240
5856 set_typeflag (SCHEME_V->loadport, T_ATOM); 6241 set_typeflag (SCHEME_V->loadport, T_ATOM);
5857 6242
5858 if (SCHEME_V->retcode == 0) 6243 if (SCHEME_V->retcode == 0)
5859 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6244 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5860} 6245}
5861 6246
5862void 6247ecb_cold void
5863scheme_load_string (SCHEME_P_ const char *cmd) 6248scheme_load_string (SCHEME_P_ const char *cmd)
5864{ 6249{
6250#if USE_PORTs
5865 dump_stack_reset (SCHEME_A); 6251 dump_stack_reset (SCHEME_A);
5866 SCHEME_V->envir = SCHEME_V->global_env; 6252 SCHEME_V->envir = SCHEME_V->global_env;
5867 SCHEME_V->file_i = 0; 6253 SCHEME_V->file_i = 0;
5868 SCHEME_V->load_stack[0].kind = port_input | port_string; 6254 SCHEME_V->load_stack[0].kind = port_input | port_string;
5869 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ 6255 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5870 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); 6256 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5871 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; 6257 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5872#if USE_PORTS
5873 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 6258 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5874#endif
5875 SCHEME_V->retcode = 0; 6259 SCHEME_V->retcode = 0;
5876 SCHEME_V->interactive_repl = 0; 6260 SCHEME_V->interactive_repl = 0;
5877 SCHEME_V->inport = SCHEME_V->loadport; 6261 SCHEME_V->inport = SCHEME_V->loadport;
5878 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6262 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5879 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6263 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5880 set_typeflag (SCHEME_V->loadport, T_ATOM); 6264 set_typeflag (SCHEME_V->loadport, T_ATOM);
5881 6265
5882 if (SCHEME_V->retcode == 0) 6266 if (SCHEME_V->retcode == 0)
5883 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6267 SCHEME_V->retcode = SCHEME_V->nesting != 0;
6268#else
6269 abort ();
6270#endif
5884} 6271}
5885 6272
5886void 6273ecb_cold void
5887scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 6274scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5888{ 6275{
5889 pointer x; 6276 pointer x;
5890 6277
5891 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 6278 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5896 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 6283 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5897} 6284}
5898 6285
5899#if !STANDALONE 6286#if !STANDALONE
5900 6287
5901void 6288ecb_cold void
5902scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 6289scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5903{ 6290{
5904 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 6291 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5905} 6292}
5906 6293
5907void 6294ecb_cold void
5908scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 6295scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5909{ 6296{
5910 int i; 6297 int i;
5911 6298
5912 for (i = 0; i < count; i++) 6299 for (i = 0; i < count; i++)
5913 scheme_register_foreign_func (SCHEME_A_ list + i); 6300 scheme_register_foreign_func (SCHEME_A_ list + i);
5914} 6301}
5915 6302
5916pointer 6303ecb_cold pointer
5917scheme_apply0 (SCHEME_P_ const char *procname) 6304scheme_apply0 (SCHEME_P_ const char *procname)
5918{ 6305{
5919 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 6306 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5920} 6307}
5921 6308
5922void 6309ecb_cold void
5923save_from_C_call (SCHEME_P) 6310save_from_C_call (SCHEME_P)
5924{ 6311{
5925 pointer saved_data = cons (car (S_SINK), 6312 pointer saved_data = cons (car (S_SINK),
5926 cons (SCHEME_V->envir, 6313 cons (SCHEME_V->envir,
5927 SCHEME_V->dump)); 6314 SCHEME_V->dump));
… …
5931 /* Truncate the dump stack so TS will return here when done, not 6318 /* Truncate the dump stack so TS will return here when done, not
5932 directly resume pre-C-call operations. */ 6319 directly resume pre-C-call operations. */
5933 dump_stack_reset (SCHEME_A); 6320 dump_stack_reset (SCHEME_A);
5934} 6321}
5935 6322
5936void 6323ecb_cold void
5937restore_from_C_call (SCHEME_P) 6324restore_from_C_call (SCHEME_P)
5938{ 6325{
5939 set_car (S_SINK, caar (SCHEME_V->c_nest)); 6326 set_car (S_SINK, caar (SCHEME_V->c_nest));
5940 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 6327 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5941 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 6328 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5942 /* Pop */ 6329 /* Pop */
5943 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 6330 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5944} 6331}
5945 6332
5946/* "func" and "args" are assumed to be already eval'ed. */ 6333/* "func" and "args" are assumed to be already eval'ed. */
5947pointer 6334ecb_cold pointer
5948scheme_call (SCHEME_P_ pointer func, pointer args) 6335scheme_call (SCHEME_P_ pointer func, pointer args)
5949{ 6336{
5950 int old_repl = SCHEME_V->interactive_repl; 6337 int old_repl = SCHEME_V->interactive_repl;
5951 6338
5952 SCHEME_V->interactive_repl = 0; 6339 SCHEME_V->interactive_repl = 0;
… …
5959 SCHEME_V->interactive_repl = old_repl; 6346 SCHEME_V->interactive_repl = old_repl;
5960 restore_from_C_call (SCHEME_A); 6347 restore_from_C_call (SCHEME_A);
5961 return SCHEME_V->value; 6348 return SCHEME_V->value;
5962} 6349}
5963 6350
5964pointer 6351ecb_cold pointer
5965scheme_eval (SCHEME_P_ pointer obj) 6352scheme_eval (SCHEME_P_ pointer obj)
5966{ 6353{
5967 int old_repl = SCHEME_V->interactive_repl; 6354 int old_repl = SCHEME_V->interactive_repl;
5968 6355
5969 SCHEME_V->interactive_repl = 0; 6356 SCHEME_V->interactive_repl = 0;
… …
5981 6368
5982/* ========== Main ========== */ 6369/* ========== Main ========== */
5983 6370
5984#if STANDALONE 6371#if STANDALONE
5985 6372
5986int 6373ecb_cold int
5987main (int argc, char **argv) 6374main (int argc, char **argv)
5988{ 6375{
5989# if USE_MULTIPLICITY 6376# if USE_MULTIPLICITY
5990 scheme ssc; 6377 scheme ssc;
5991 scheme *const SCHEME_V = &ssc; 6378 scheme *const SCHEME_V = &ssc;
… …
5993# endif 6380# endif
5994 int fin; 6381 int fin;
5995 char *file_name = InitFile; 6382 char *file_name = InitFile;
5996 int retcode; 6383 int retcode;
5997 int isfile = 1; 6384 int isfile = 1;
6385#if EXPERIMENT
5998 system ("ps v $PPID");//D 6386 system ("ps v $PPID");
6387#endif
5999 6388
6000 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6389 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6001 { 6390 {
6002 putstr (SCHEME_A_ "Usage: tinyscheme -?\n"); 6391 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6003 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n"); 6392 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
… …
6032 } 6421 }
6033#endif 6422#endif
6034 6423
6035 do 6424 do
6036 { 6425 {
6037#if USE_PORTS
6038 if (strcmp (file_name, "-") == 0) 6426 if (strcmp (file_name, "-") == 0)
6039 fin = STDIN_FILENO; 6427 fin = STDIN_FILENO;
6040 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) 6428 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
6041 { 6429 {
6042 pointer args = NIL; 6430 pointer args = NIL;
… …
6060 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args); 6448 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
6061 6449
6062 } 6450 }
6063 else 6451 else
6064 fin = open (file_name, O_RDONLY); 6452 fin = open (file_name, O_RDONLY);
6065#endif
6066 6453
6067 if (isfile && fin < 0) 6454 if (isfile && fin < 0)
6068 { 6455 {
6069 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); 6456 putstr (SCHEME_A_ "Could not open file ");
6457 putstr (SCHEME_A_ file_name);
6458 putcharacter (SCHEME_A_ '\n');
6070 } 6459 }
6071 else 6460 else
6072 { 6461 {
6073 if (isfile) 6462 if (isfile)
6074 scheme_load_named_file (SCHEME_A_ fin, file_name); 6463 scheme_load_named_file (SCHEME_A_ fin, file_name);
6075 else 6464 else
6076 scheme_load_string (SCHEME_A_ file_name); 6465 scheme_load_string (SCHEME_A_ file_name);
6077 6466
6078#if USE_PORTS
6079 if (!isfile || fin != STDIN_FILENO) 6467 if (!isfile || fin != STDIN_FILENO)
6080 { 6468 {
6081 if (SCHEME_V->retcode != 0) 6469 if (SCHEME_V->retcode != 0)
6082 { 6470 {
6083 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); 6471 putstr (SCHEME_A_ "Errors encountered reading ");
6472 putstr (SCHEME_A_ file_name);
6473 putcharacter (SCHEME_A_ '\n');
6084 } 6474 }
6085 6475
6086 if (isfile) 6476 if (isfile)
6087 close (fin); 6477 close (fin);
6088 } 6478 }
6089#endif
6090 } 6479 }
6091 6480
6092 file_name = *argv++; 6481 file_name = *argv++;
6093 } 6482 }
6094 while (file_name != 0); 6483 while (file_name != 0);

Diff Legend

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