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.53 by root, Tue Dec 1 02:21:49 2015 UTC vs.
Revision 1.67 by root, Mon Dec 7 19:49:35 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
194 205
195enum scheme_types 206enum scheme_types
196{ 207{
197 T_INTEGER, 208 T_INTEGER,
209 T_CHARACTER,
198 T_REAL, 210 T_REAL,
199 T_STRING, 211 T_STRING,
200 T_SYMBOL, 212 T_SYMBOL,
201 T_PROC, 213 T_PROC,
202 T_PAIR, /* also used for free cells */ 214 T_PAIR, /* also used for free cells */
203 T_CLOSURE, 215 T_CLOSURE,
216 T_BYTECODE, // temp
217 T_MACRO,
204 T_CONTINUATION, 218 T_CONTINUATION,
205 T_FOREIGN, 219 T_FOREIGN,
206 T_CHARACTER,
207 T_PORT, 220 T_PORT,
208 T_VECTOR, 221 T_VECTOR,
209 T_MACRO,
210 T_PROMISE, 222 T_PROMISE,
211 T_ENVIRONMENT, 223 T_ENVIRONMENT,
212 /* one more... */ 224 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;
… …
250static num num_op (enum num_op op, num a, num b); 263static num num_op (enum num_op op, num a, num b);
251static num num_intdiv (num a, num b); 264static num num_intdiv (num a, num b);
252static num num_rem (num a, num b); 265static num num_rem (num a, num b);
253static num num_mod (num a, num b); 266static num num_mod (num a, num b);
254 267
255#if USE_MATH
256static double round_per_R5RS (double x);
257#endif
258static int is_zero_rvalue (RVALUE x); 268static int is_zero_rvalue (RVALUE x);
259 269
260static num num_zero; 270static num num_zero;
261static num num_one; 271static num num_one;
262 272
… …
319string_value (pointer p) 329string_value (pointer p)
320{ 330{
321 return strvalue (p); 331 return strvalue (p);
322} 332}
323 333
324#define ivalue_unchecked(p) CELL(p)->object.ivalue 334#define ivalue_unchecked(p) (CELL(p)->object.ivalue + 0)
325#define set_ivalue(p,v) CELL(p)->object.ivalue = (v) 335#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
326 336
327#if USE_REAL 337#if USE_REAL
328#define rvalue_unchecked(p) CELL(p)->object.rvalue 338#define rvalue_unchecked(p) CELL(p)->object.rvalue
329#define set_rvalue(p,v) CELL(p)->object.rvalue = (v) 339#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
… …
374 384
375static pointer cadar (pointer p) { return car (cdr (car (p))); } 385static pointer cadar (pointer p) { return car (cdr (car (p))); }
376static pointer caddr (pointer p) { return car (cdr (cdr (p))); } 386static pointer caddr (pointer p) { return car (cdr (cdr (p))); }
377static pointer cdaar (pointer p) { return cdr (car (car (p))); } 387static pointer cdaar (pointer p) { return cdr (car (car (p))); }
378 388
389static pointer cadddr (pointer p) { return car (car (car (cdr (p)))); }
390
379INTERFACE void 391INTERFACE void
380set_car (pointer p, pointer q) 392set_car (pointer p, pointer q)
381{ 393{
382 CELL(p)->object.cons.car = CELL (q); 394 CELL(p)->object.cons.car = CELL (q);
383} 395}
… …
499 511
500#define is_atom(p) (typeflag (p) & T_ATOM) 512#define is_atom(p) (typeflag (p) & T_ATOM)
501#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM) 513#define setatom(p) set_typeflag ((p), typeflag (p) | T_ATOM)
502#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM) 514#define clratom(p) set_typeflag ((p), typeflag (p) & ~T_ATOM)
503 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
504#define is_mark(p) (typeflag (p) & T_MARK) 521#define is_mark(p) (typeflag (p) & T_MARK)
505#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK) 522#define setmark(p) set_typeflag ((p), typeflag (p) | T_MARK)
506#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK) 523#define clrmark(p) set_typeflag ((p), typeflag (p) & ~T_MARK)
524#endif
507 525
508INTERFACE int 526INTERFACE int
509is_immutable (pointer p) 527is_immutable (pointer p)
510{ 528{
511 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING; 529 return typeflag (p) & T_IMMUTABLE && USE_ERROR_CHECKING;
… …
523 proper list: length 541 proper list: length
524 circular list: -1 542 circular list: -1
525 not even a pair: -2 543 not even a pair: -2
526 dotted list: -2 minus length before dot 544 dotted list: -2 minus length before dot
527*/ 545*/
528INTERFACE int 546ecb_hot INTERFACE int
529list_length (SCHEME_P_ pointer a) 547list_length (SCHEME_P_ pointer a)
530{ 548{
531 int i = 0; 549 int i = 0;
532 pointer slow, fast; 550 pointer slow, fast;
533 551
… …
572{ 590{
573 return list_length (SCHEME_A_ a) >= 0; 591 return list_length (SCHEME_A_ a) >= 0;
574} 592}
575 593
576#if USE_CHAR_CLASSIFIERS 594#if USE_CHAR_CLASSIFIERS
595
577ecb_inline int 596ecb_inline int
578Cisalpha (int c) 597Cisalpha (int c)
579{ 598{
580 return isascii (c) && isalpha (c); 599 return isascii (c) && isalpha (c);
581} 600}
… …
639 "gs", 658 "gs",
640 "rs", 659 "rs",
641 "us" 660 "us"
642}; 661};
643 662
644static int 663ecb_cold static int
645is_ascii_name (const char *name, int *pc) 664is_ascii_name (const char *name, int *pc)
646{ 665{
647 int i; 666 int i;
648 667
649 for (i = 0; i < 32; i++) 668 for (i = 0; i < 32; i++)
… …
671static int file_interactive (SCHEME_P); 690static int file_interactive (SCHEME_P);
672ecb_inline int is_one_of (const char *s, int c); 691ecb_inline int is_one_of (const char *s, int c);
673static int alloc_cellseg (SCHEME_P); 692static int alloc_cellseg (SCHEME_P);
674ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 693ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
675static void finalize_cell (SCHEME_P_ pointer a); 694static void finalize_cell (SCHEME_P_ pointer a);
676static int count_consecutive_cells (pointer x, int needed);
677static 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);
678static pointer mk_number (SCHEME_P_ const num n); 696static pointer mk_number (SCHEME_P_ const num n);
679static 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);
680static pointer mk_vector (SCHEME_P_ uint32_t len); 698static pointer mk_vector (SCHEME_P_ uint32_t len);
681static pointer mk_atom (SCHEME_P_ char *q); 699static pointer mk_atom (SCHEME_P_ char *q);
682static pointer mk_sharp_const (SCHEME_P_ char *name); 700static pointer mk_sharp_const (SCHEME_P_ char *name);
683 701
702static pointer mk_port (SCHEME_P_ port *p);
703
684#if USE_PORTS 704#if USE_PORTS
685static pointer mk_port (SCHEME_P_ port *p);
686static pointer port_from_filename (SCHEME_P_ const char *fn, int prop); 705static pointer port_from_filename (SCHEME_P_ const char *fn, int prop);
687static pointer port_from_file (SCHEME_P_ int, int prop); 706static pointer port_from_file (SCHEME_P_ int, int prop);
688static 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);
689static 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);
690static port *port_rep_from_file (SCHEME_P_ int, int prop); 709static port *port_rep_from_file (SCHEME_P_ int, int prop);
691static 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);
692static void port_close (SCHEME_P_ pointer p, int flag); 711static void port_close (SCHEME_P_ pointer p, int flag);
693#endif 712#endif
713
694static void mark (pointer a); 714static void mark (pointer a);
695static void gc (SCHEME_P_ pointer a, pointer b); 715static void gc (SCHEME_P_ pointer a, pointer b);
696static int basic_inchar (port *pt); 716static int basic_inchar (port *pt);
697static int inchar (SCHEME_P); 717static int inchar (SCHEME_P);
698static void backchar (SCHEME_P_ int c); 718static void backchar (SCHEME_P_ int c);
699static char *readstr_upto (SCHEME_P_ int skip, const char *delim); 719static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
700static pointer readstrexp (SCHEME_P_ char delim); 720static pointer readstrexp (SCHEME_P_ char delim);
701ecb_inline int skipspace (SCHEME_P); 721static int skipspace (SCHEME_P);
702static int token (SCHEME_P); 722static int token (SCHEME_P);
703static void printslashstring (SCHEME_P_ char *s, int len); 723static void printslashstring (SCHEME_P_ char *s, int len);
704static 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);
705static void printatom (SCHEME_P_ pointer l, int f); 725static void printatom (SCHEME_P_ pointer l, int f);
706static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op); 726static pointer mk_proc (SCHEME_P_ enum scheme_opcodes op);
… …
872 } 892 }
873 893
874 return ret; 894 return ret;
875} 895}
876 896
877#if USE_MATH
878
879/* Round to nearest. Round to even if midway */
880static double
881round_per_R5RS (double x)
882{
883 double fl = floor (x);
884 double ce = ceil (x);
885 double dfl = x - fl;
886 double dce = ce - x;
887
888 if (dfl > dce)
889 return ce;
890 else if (dfl < dce)
891 return fl;
892 else
893 {
894 if (fmod (fl, 2) == 0) /* I imagine this holds */
895 return fl;
896 else
897 return ce;
898 }
899}
900#endif
901
902static int 897static int
903is_zero_rvalue (RVALUE x) 898is_zero_rvalue (RVALUE x)
904{ 899{
905 return x == 0; 900 return x == 0;
906#if 0 901#if 0
… …
911#endif 906#endif
912#endif 907#endif
913} 908}
914 909
915/* allocate new cell segment */ 910/* allocate new cell segment */
916static int 911ecb_cold static int
917alloc_cellseg (SCHEME_P) 912alloc_cellseg (SCHEME_P)
918{ 913{
919 struct cell *newp; 914 struct cell *newp;
920 struct cell *last; 915 struct cell *last;
921 struct cell *p; 916 struct cell *p;
… …
930 925
931 if (!cp && USE_ERROR_CHECKING) 926 if (!cp && USE_ERROR_CHECKING)
932 return k; 927 return k;
933 928
934 i = ++SCHEME_V->last_cell_seg; 929 i = ++SCHEME_V->last_cell_seg;
935 SCHEME_V->alloc_seg[i] = cp;
936 930
937 newp = (struct cell *)cp; 931 newp = (struct cell *)cp;
938 SCHEME_V->cell_seg[i] = newp; 932 SCHEME_V->cell_seg[i] = newp;
939 SCHEME_V->cell_segsize[i] = segsize; 933 SCHEME_V->cell_segsize[i] = segsize;
940 SCHEME_V->fcells += segsize; 934 SCHEME_V->fcells += segsize;
941 last = newp + segsize - 1; 935 last = newp + segsize - 1;
942 936
943 for (p = newp; p <= last; p++) 937 for (p = newp; p <= last; p++)
944 { 938 {
945 pointer cp = POINTER (p); 939 pointer cp = POINTER (p);
940 clrmark (cp);
946 set_typeflag (cp, T_PAIR); 941 set_typeflag (cp, T_PAIR);
947 set_car (cp, NIL); 942 set_car (cp, NIL);
948 set_cdr (cp, POINTER (p + 1)); 943 set_cdr (cp, POINTER (p + 1));
949 } 944 }
950 945
… …
963 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 958 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
964 return S_SINK; 959 return S_SINK;
965 960
966 if (SCHEME_V->free_cell == NIL) 961 if (SCHEME_V->free_cell == NIL)
967 { 962 {
968 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;
969 964
970 gc (SCHEME_A_ a, b); 965 gc (SCHEME_A_ a, b);
971 966
972 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)
973 { 968 {
… …
992 } 987 }
993} 988}
994 989
995/* To retain recent allocs before interpreter knows about them - 990/* To retain recent allocs before interpreter knows about them -
996 Tehom */ 991 Tehom */
997static void 992ecb_hot static void
998push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 993push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
999{ 994{
1000 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 995 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1001 996
1002 set_typeflag (holder, T_PAIR); 997 set_typeflag (holder, T_PAIR);
… …
1004 set_car (holder, recent); 999 set_car (holder, recent);
1005 set_cdr (holder, car (S_SINK)); 1000 set_cdr (holder, car (S_SINK));
1006 set_car (S_SINK, holder); 1001 set_car (S_SINK, holder);
1007} 1002}
1008 1003
1009static pointer 1004ecb_hot static pointer
1010get_cell (SCHEME_P_ pointer a, pointer b) 1005get_cell (SCHEME_P_ pointer a, pointer b)
1011{ 1006{
1012 pointer cell = get_cell_x (SCHEME_A_ a, b); 1007 pointer cell = get_cell_x (SCHEME_A_ a, b);
1013 1008
1014 /* 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
… …
1071#endif 1066#endif
1072 1067
1073/* Medium level cell allocation */ 1068/* Medium level cell allocation */
1074 1069
1075/* get new cons cell */ 1070/* get new cons cell */
1076pointer 1071ecb_hot static pointer
1077xcons (SCHEME_P_ pointer a, pointer b, int immutable) 1072xcons (SCHEME_P_ pointer a, pointer b)
1078{ 1073{
1079 pointer x = get_cell (SCHEME_A_ a, b); 1074 pointer x = get_cell (SCHEME_A_ a, b);
1080 1075
1081 set_typeflag (x, T_PAIR); 1076 set_typeflag (x, T_PAIR);
1082
1083 if (immutable)
1084 setimmutable (x);
1085 1077
1086 set_car (x, a); 1078 set_car (x, a);
1087 set_cdr (x, b); 1079 set_cdr (x, b);
1088 1080
1089 return x; 1081 return x;
1090} 1082}
1091 1083
1092static 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
1093generate_symbol (SCHEME_P_ const char *name) 1096generate_symbol (SCHEME_P_ const char *name)
1094{ 1097{
1095 pointer x = mk_string (SCHEME_A_ name); 1098 pointer x = mk_string (SCHEME_A_ name);
1096 setimmutable (x); 1099 setimmutable (x);
1097 set_typeflag (x, T_SYMBOL | T_ATOM); 1100 set_typeflag (x, T_SYMBOL | T_ATOM);
… …
1103#ifndef USE_OBJECT_LIST 1106#ifndef USE_OBJECT_LIST
1104 1107
1105static int 1108static int
1106hash_fn (const char *key, int table_size) 1109hash_fn (const char *key, int table_size)
1107{ 1110{
1108 const unsigned char *p = key; 1111 const unsigned char *p = (unsigned char *)key;
1109 uint32_t hash = 2166136261; 1112 uint32_t hash = 2166136261U;
1110 1113
1111 while (*p) 1114 while (*p)
1112 hash = (hash ^ *p++) * 16777619; 1115 hash = (hash ^ *p++) * 16777619;
1113 1116
1114 return hash % table_size; 1117 return hash % table_size;
1115} 1118}
1116 1119
1117static pointer 1120ecb_cold static pointer
1118oblist_initial_value (SCHEME_P) 1121oblist_initial_value (SCHEME_P)
1119{ 1122{
1120 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */ 1123 return mk_vector (SCHEME_A_ 461); /* probably should be bigger */
1121} 1124}
1122 1125
1123/* returns the new symbol */ 1126/* returns the new symbol */
1124static pointer 1127ecb_cold static pointer
1125oblist_add_by_name (SCHEME_P_ const char *name) 1128oblist_add_by_name (SCHEME_P_ const char *name)
1126{ 1129{
1127 pointer x = generate_symbol (SCHEME_A_ name); 1130 pointer x = generate_symbol (SCHEME_A_ name);
1128 int location = hash_fn (name, veclength (SCHEME_V->oblist)); 1131 int location = hash_fn (name, veclength (SCHEME_V->oblist));
1129 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)));
1130 return x; 1133 return x;
1131} 1134}
1132 1135
1133ecb_inline pointer 1136ecb_cold static pointer
1134oblist_find_by_name (SCHEME_P_ const char *name) 1137oblist_find_by_name (SCHEME_P_ const char *name)
1135{ 1138{
1136 int location; 1139 int location;
1137 pointer x; 1140 pointer x;
1138 char *s; 1141 char *s;
… …
1149 } 1152 }
1150 1153
1151 return NIL; 1154 return NIL;
1152} 1155}
1153 1156
1154static pointer 1157ecb_cold static pointer
1155oblist_all_symbols (SCHEME_P) 1158oblist_all_symbols (SCHEME_P)
1156{ 1159{
1157 int i; 1160 int i;
1158 pointer x; 1161 pointer x;
1159 pointer ob_list = NIL; 1162 pointer ob_list = NIL;
… …
1165 return ob_list; 1168 return ob_list;
1166} 1169}
1167 1170
1168#else 1171#else
1169 1172
1170static pointer 1173ecb_cold static pointer
1171oblist_initial_value (SCHEME_P) 1174oblist_initial_value (SCHEME_P)
1172{ 1175{
1173 return NIL; 1176 return NIL;
1174} 1177}
1175 1178
1176ecb_inline pointer 1179ecb_cold static pointer
1177oblist_find_by_name (SCHEME_P_ const char *name) 1180oblist_find_by_name (SCHEME_P_ const char *name)
1178{ 1181{
1179 pointer x; 1182 pointer x;
1180 char *s; 1183 char *s;
1181 1184
… …
1190 1193
1191 return NIL; 1194 return NIL;
1192} 1195}
1193 1196
1194/* returns the new symbol */ 1197/* returns the new symbol */
1195static pointer 1198ecb_cold static pointer
1196oblist_add_by_name (SCHEME_P_ const char *name) 1199oblist_add_by_name (SCHEME_P_ const char *name)
1197{ 1200{
1198 pointer x = generate_symbol (SCHEME_A_ name); 1201 pointer x = generate_symbol (SCHEME_A_ name);
1199 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist); 1202 SCHEME_V->oblist = immutable_cons (x, SCHEME_V->oblist);
1200 return x; 1203 return x;
1201} 1204}
1202 1205
1203static pointer 1206ecb_cold static pointer
1204oblist_all_symbols (SCHEME_P) 1207oblist_all_symbols (SCHEME_P)
1205{ 1208{
1206 return SCHEME_V->oblist; 1209 return SCHEME_V->oblist;
1207} 1210}
1208 1211
1209#endif 1212#endif
1210 1213
1211#if USE_PORTS
1212static pointer 1214ecb_cold static pointer
1213mk_port (SCHEME_P_ port *p) 1215mk_port (SCHEME_P_ port *p)
1214{ 1216{
1215 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1217 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1216 1218
1217 set_typeflag (x, T_PORT | T_ATOM); 1219 set_typeflag (x, T_PORT | T_ATOM);
1218 set_port (x, p); 1220 set_port (x, p);
1219 1221
1220 return x; 1222 return x;
1221} 1223}
1222#endif
1223 1224
1224pointer 1225ecb_cold pointer
1225mk_foreign_func (SCHEME_P_ foreign_func f) 1226mk_foreign_func (SCHEME_P_ foreign_func f)
1226{ 1227{
1227 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1228 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1228 1229
1229 set_typeflag (x, T_FOREIGN | T_ATOM); 1230 set_typeflag (x, T_FOREIGN | T_ATOM);
… …
1258 if (!*pp) 1259 if (!*pp)
1259 { 1260 {
1260 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1261 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1261 1262
1262 set_typeflag (x, T_INTEGER | T_ATOM); 1263 set_typeflag (x, T_INTEGER | T_ATOM);
1263 setimmutable (x); /* shouldn't do anythi9ng, doesn't cost anything */ 1264 setimmutable (x); /* shouldn't do anything, doesn't cost anything */
1264 set_ivalue (x, n); 1265 set_ivalue (x, n);
1265 1266
1266 *pp = x; 1267 *pp = x;
1267 } 1268 }
1268 1269
… …
1394 x = oblist_add_by_name (SCHEME_A_ name); 1395 x = oblist_add_by_name (SCHEME_A_ name);
1395 1396
1396 return x; 1397 return x;
1397} 1398}
1398 1399
1399INTERFACE pointer 1400ecb_cold INTERFACE pointer
1400gensym (SCHEME_P) 1401gensym (SCHEME_P)
1401{ 1402{
1402 pointer x; 1403 pointer x;
1403 char name[40] = "gensym-"; 1404 char name[40] = "gensym-";
1404 xnum (name + 7, ++SCHEME_V->gensym_cnt); 1405 xnum (name + 7, ++SCHEME_V->gensym_cnt);
… …
1411{ 1412{
1412 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;
1413} 1414}
1414 1415
1415/* make symbol or number atom from string */ 1416/* make symbol or number atom from string */
1416static pointer 1417ecb_cold static pointer
1417mk_atom (SCHEME_P_ char *q) 1418mk_atom (SCHEME_P_ char *q)
1418{ 1419{
1419 char c, *p; 1420 char c, *p;
1420 int has_dec_point = 0; 1421 int has_dec_point = 0;
1421 int has_fp_exp = 0; 1422 int has_fp_exp = 0;
… …
1492 1493
1493 return mk_integer (SCHEME_A_ strtol (q, 0, 10)); 1494 return mk_integer (SCHEME_A_ strtol (q, 0, 10));
1494} 1495}
1495 1496
1496/* make constant */ 1497/* make constant */
1497static pointer 1498ecb_cold static pointer
1498mk_sharp_const (SCHEME_P_ char *name) 1499mk_sharp_const (SCHEME_P_ char *name)
1499{ 1500{
1500 if (!strcmp (name, "t")) 1501 if (!strcmp (name, "t"))
1501 return S_T; 1502 return S_T;
1502 else if (!strcmp (name, "f")) 1503 else if (!strcmp (name, "f"))
1503 return S_F; 1504 return S_F;
1504 else if (*name == '\\') /* #\w (character) */ 1505 else if (*name == '\\') /* #\w (character) */
1505 { 1506 {
1506 int c; 1507 int c;
1507 1508
1509 // TODO: optimise
1508 if (stricmp (name + 1, "space") == 0) 1510 if (stricmp (name + 1, "space") == 0)
1509 c = ' '; 1511 c = ' ';
1510 else if (stricmp (name + 1, "newline") == 0) 1512 else if (stricmp (name + 1, "newline") == 0)
1511 c = '\n'; 1513 c = '\n';
1512 else if (stricmp (name + 1, "return") == 0) 1514 else if (stricmp (name + 1, "return") == 0)
1513 c = '\r'; 1515 c = '\r';
1514 else if (stricmp (name + 1, "tab") == 0) 1516 else if (stricmp (name + 1, "tab") == 0)
1515 c = '\t'; 1517 c = '\t';
1518 else if (stricmp (name + 1, "alarm") == 0)
1519 c = 0x07;
1520 else if (stricmp (name + 1, "backspace") == 0)
1521 c = 0x08;
1522 else if (stricmp (name + 1, "escape") == 0)
1523 c = 0x1b;
1524 else if (stricmp (name + 1, "delete") == 0)
1525 c = 0x7f;
1526 else if (stricmp (name + 1, "null") == 0)
1527 c = 0;
1516 else if (name[1] == 'x' && name[2] != 0) 1528 else if (name[1] == 'x' && name[2] != 0)
1517 { 1529 {
1518 long c1 = strtol (name + 2, 0, 16); 1530 long c1 = strtol (name + 2, 0, 16);
1519 1531
1520 if (0 <= c1 && c1 <= UCHAR_MAX) 1532 if (0 <= c1 && c1 <= UCHAR_MAX)
… …
1534 return mk_character (SCHEME_A_ c); 1546 return mk_character (SCHEME_A_ c);
1535 } 1547 }
1536 else 1548 else
1537 { 1549 {
1538 /* identify base by string index */ 1550 /* identify base by string index */
1539 const char baseidx[17] = "ffbf" "ffff" "ofdf" "ffff" "x"; 1551 const char baseidx[18] = "ffbf" "ffff" "ofdf" "ffff" "x";
1540 char *base = strchr (baseidx, *name); 1552 char *base = strchr (baseidx, *name);
1541 1553
1542 if (base) 1554 if (base && *base)
1543 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx)); 1555 return mk_integer (SCHEME_A_ strtol (name + 1, 0, base - baseidx));
1544 1556
1545 return NIL; 1557 return NIL;
1546 } 1558 }
1547} 1559}
1548 1560
1549/* ========== 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}
1550 1581
1551/*-- 1582/*--
1552 * 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,
1553 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, 1584 * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
1554 * for marking. 1585 * for marking.
1555 * 1586 *
1556 * The exception is vectors - vectors are currently marked recursively, 1587 * The exception is vectors - vectors are currently marked recursively,
1557 * 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
1558 * word of context in the vector 1589 * word of context in the vector
1559 */ 1590 */
1560static void 1591ecb_hot static void
1561mark (pointer a) 1592mark (pointer a)
1562{ 1593{
1563 pointer t, q, p; 1594 pointer t, q, p;
1564 1595
1565 t = 0; 1596 t = 0;
… …
1622 p = q; 1653 p = q;
1623 goto E6; 1654 goto E6;
1624 } 1655 }
1625} 1656}
1626 1657
1627/* garbage collection. parameter a, b is marked. */ 1658ecb_hot static void
1628static void 1659gc_free (SCHEME_P)
1629gc (SCHEME_P_ pointer a, pointer b)
1630{ 1660{
1631 int i; 1661 int i;
1632
1633 if (SCHEME_V->gc_verbose)
1634 putstr (SCHEME_A_ "gc...");
1635
1636 /* mark system globals */
1637 mark (SCHEME_V->oblist);
1638 mark (SCHEME_V->global_env);
1639
1640 /* mark current registers */
1641 mark (SCHEME_V->args);
1642 mark (SCHEME_V->envir);
1643 mark (SCHEME_V->code);
1644 dump_stack_mark (SCHEME_A);
1645 mark (SCHEME_V->value);
1646 mark (SCHEME_V->inport);
1647 mark (SCHEME_V->save_inport);
1648 mark (SCHEME_V->outport);
1649 mark (SCHEME_V->loadport);
1650
1651 /* Mark recent objects the interpreter doesn't know about yet. */
1652 mark (car (S_SINK));
1653 /* Mark any older stuff above nested C calls */
1654 mark (SCHEME_V->c_nest);
1655
1656#if USE_INTCACHE
1657 /* mark intcache */
1658 for (i = INTCACHE_MIN; i <= INTCACHE_MAX; ++i)
1659 if (SCHEME_V->intcache[i - INTCACHE_MIN])
1660 mark (SCHEME_V->intcache[i - INTCACHE_MIN]);
1661#endif
1662
1663 /* mark variables a, b */
1664 mark (a);
1665 mark (b);
1666
1667 /* garbage collect */
1668 clrmark (NIL);
1669 SCHEME_V->fcells = 0;
1670 SCHEME_V->free_cell = NIL;
1671
1672 if (SCHEME_V->gc_verbose)
1673 putstr (SCHEME_A_ "freeing...");
1674
1675 uint32_t total = 0; 1662 uint32_t total = 0;
1676 1663
1677 /* Here we scan the cells to build the free-list. */ 1664 /* Here we scan the cells to build the free-list. */
1678 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1665 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1679 { 1666 {
… …
1708 { 1695 {
1709 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");
1710 } 1697 }
1711} 1698}
1712 1699
1713static void 1700/* garbage collection. parameter a, b is marked. */
1714finalize_cell (SCHEME_P_ pointer a) 1701ecb_cold static void
1702gc (SCHEME_P_ pointer a, pointer b)
1715{ 1703{
1716 /* TODO, fast bitmap check? */ 1704 int i;
1717 if (is_string (a) || is_symbol (a))
1718 free (strvalue (a));
1719 else if (is_vector (a))
1720 free (vecvalue (a));
1721#if USE_PORTS
1722 else if (is_port (a))
1723 {
1724 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1725 port_close (SCHEME_A_ a, port_input | port_output);
1726 1705
1727 free (port (a)); 1706 if (SCHEME_V->gc_verbose)
1728 } 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]);
1729#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);
1730} 1749}
1731 1750
1732/* ========== Routines for Reading ========== */ 1751/* ========== Routines for Reading ========== */
1733 1752
1734static int 1753ecb_cold static int
1735file_push (SCHEME_P_ const char *fname) 1754file_push (SCHEME_P_ const char *fname)
1736{ 1755{
1737#if USE_PORTS
1738 int fin; 1756 int fin;
1739 1757
1740 if (SCHEME_V->file_i == MAXFIL - 1) 1758 if (SCHEME_V->file_i == MAXFIL - 1)
1741 return 0; 1759 return 0;
1742 1760
… …
1759 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);
1760#endif 1778#endif
1761 } 1779 }
1762 1780
1763 return fin >= 0; 1781 return fin >= 0;
1764
1765#else
1766 return 1;
1767#endif
1768} 1782}
1769 1783
1770static void 1784ecb_cold static void
1771file_pop (SCHEME_P) 1785file_pop (SCHEME_P)
1772{ 1786{
1773 if (SCHEME_V->file_i != 0) 1787 if (SCHEME_V->file_i != 0)
1774 { 1788 {
1775 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1789 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
… …
1779 SCHEME_V->file_i--; 1793 SCHEME_V->file_i--;
1780 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);
1781 } 1795 }
1782} 1796}
1783 1797
1784static int 1798ecb_cold static int
1785file_interactive (SCHEME_P) 1799file_interactive (SCHEME_P)
1786{ 1800{
1787#if USE_PORTS 1801#if USE_PORTS
1788 return SCHEME_V->file_i == 0 1802 return SCHEME_V->file_i == 0
1789 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1803 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
… …
1792 return 0; 1806 return 0;
1793#endif 1807#endif
1794} 1808}
1795 1809
1796#if USE_PORTS 1810#if USE_PORTS
1797static port * 1811ecb_cold static port *
1798port_rep_from_filename (SCHEME_P_ const char *fn, int prop) 1812port_rep_from_filename (SCHEME_P_ const char *fn, int prop)
1799{ 1813{
1800 int fd; 1814 int fd;
1801 int flags; 1815 int flags;
1802 char *rw; 1816 char *rw;
… …
1825# endif 1839# endif
1826 1840
1827 return pt; 1841 return pt;
1828} 1842}
1829 1843
1830static pointer 1844ecb_cold static pointer
1831port_from_filename (SCHEME_P_ const char *fn, int prop) 1845port_from_filename (SCHEME_P_ const char *fn, int prop)
1832{ 1846{
1833 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop); 1847 port *pt = port_rep_from_filename (SCHEME_A_ fn, prop);
1834 1848
1835 if (!pt && USE_ERROR_CHECKING) 1849 if (!pt && USE_ERROR_CHECKING)
1836 return NIL; 1850 return NIL;
1837 1851
1838 return mk_port (SCHEME_A_ pt); 1852 return mk_port (SCHEME_A_ pt);
1839} 1853}
1840 1854
1841static port * 1855ecb_cold static port *
1842port_rep_from_file (SCHEME_P_ int f, int prop) 1856port_rep_from_file (SCHEME_P_ int f, int prop)
1843{ 1857{
1844 port *pt = malloc (sizeof *pt); 1858 port *pt = malloc (sizeof *pt);
1845 1859
1846 if (!pt && USE_ERROR_CHECKING) 1860 if (!pt && USE_ERROR_CHECKING)
… …
1851 pt->rep.stdio.file = f; 1865 pt->rep.stdio.file = f;
1852 pt->rep.stdio.closeit = 0; 1866 pt->rep.stdio.closeit = 0;
1853 return pt; 1867 return pt;
1854} 1868}
1855 1869
1856static pointer 1870ecb_cold static pointer
1857port_from_file (SCHEME_P_ int f, int prop) 1871port_from_file (SCHEME_P_ int f, int prop)
1858{ 1872{
1859 port *pt = port_rep_from_file (SCHEME_A_ f, prop); 1873 port *pt = port_rep_from_file (SCHEME_A_ f, prop);
1860 1874
1861 if (!pt && USE_ERROR_CHECKING) 1875 if (!pt && USE_ERROR_CHECKING)
1862 return NIL; 1876 return NIL;
1863 1877
1864 return mk_port (SCHEME_A_ pt); 1878 return mk_port (SCHEME_A_ pt);
1865} 1879}
1866 1880
1867static port * 1881ecb_cold static port *
1868port_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)
1869{ 1883{
1870 port *pt = malloc (sizeof (port)); 1884 port *pt = malloc (sizeof (port));
1871 1885
1872 if (!pt && USE_ERROR_CHECKING) 1886 if (!pt && USE_ERROR_CHECKING)
… …
1878 pt->rep.string.curr = start; 1892 pt->rep.string.curr = start;
1879 pt->rep.string.past_the_end = past_the_end; 1893 pt->rep.string.past_the_end = past_the_end;
1880 return pt; 1894 return pt;
1881} 1895}
1882 1896
1883static pointer 1897ecb_cold static pointer
1884port_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)
1885{ 1899{
1886 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);
1887 1901
1888 if (!pt && USE_ERROR_CHECKING) 1902 if (!pt && USE_ERROR_CHECKING)
… …
1891 return mk_port (SCHEME_A_ pt); 1905 return mk_port (SCHEME_A_ pt);
1892} 1906}
1893 1907
1894# define BLOCK_SIZE 256 1908# define BLOCK_SIZE 256
1895 1909
1896static port * 1910ecb_cold static port *
1897port_rep_from_scratch (SCHEME_P) 1911port_rep_from_scratch (SCHEME_P)
1898{ 1912{
1899 char *start; 1913 char *start;
1900 port *pt = malloc (sizeof (port)); 1914 port *pt = malloc (sizeof (port));
1901 1915
… …
1915 pt->rep.string.curr = start; 1929 pt->rep.string.curr = start;
1916 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1; 1930 pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
1917 return pt; 1931 return pt;
1918} 1932}
1919 1933
1920static pointer 1934ecb_cold static pointer
1921port_from_scratch (SCHEME_P) 1935port_from_scratch (SCHEME_P)
1922{ 1936{
1923 port *pt = port_rep_from_scratch (SCHEME_A); 1937 port *pt = port_rep_from_scratch (SCHEME_A);
1924 1938
1925 if (!pt && USE_ERROR_CHECKING) 1939 if (!pt && USE_ERROR_CHECKING)
1926 return NIL; 1940 return NIL;
1927 1941
1928 return mk_port (SCHEME_A_ pt); 1942 return mk_port (SCHEME_A_ pt);
1929} 1943}
1930 1944
1931static void 1945ecb_cold static void
1932port_close (SCHEME_P_ pointer p, int flag) 1946port_close (SCHEME_P_ pointer p, int flag)
1933{ 1947{
1934 port *pt = port (p); 1948 port *pt = port (p);
1935 1949
1936 pt->kind &= ~flag; 1950 pt->kind &= ~flag;
… …
1956 } 1970 }
1957} 1971}
1958#endif 1972#endif
1959 1973
1960/* get new character from input file */ 1974/* get new character from input file */
1961static int 1975ecb_cold static int
1962inchar (SCHEME_P) 1976inchar (SCHEME_P)
1963{ 1977{
1964 int c; 1978 int c;
1965 port *pt = port (SCHEME_V->inport); 1979 port *pt = port (SCHEME_V->inport);
1966 1980
… …
1980 } 1994 }
1981 1995
1982 return c; 1996 return c;
1983} 1997}
1984 1998
1985static int ungot = -1; 1999ecb_cold static int
1986
1987static int
1988basic_inchar (port *pt) 2000basic_inchar (port *pt)
1989{ 2001{
1990#if USE_PORTS
1991 if (pt->unget != -1) 2002 if (pt->unget != -1)
1992 { 2003 {
1993 int r = pt->unget; 2004 int r = pt->unget;
1994 pt->unget = -1; 2005 pt->unget = -1;
1995 return r; 2006 return r;
1996 } 2007 }
1997 2008
2009#if USE_PORTS
1998 if (pt->kind & port_file) 2010 if (pt->kind & port_file)
1999 { 2011 {
2000 char c; 2012 char c;
2001 2013
2002 if (!read (pt->rep.stdio.file, &c, 1)) 2014 if (!read (pt->rep.stdio.file, &c, 1))
… …
2010 return EOF; 2022 return EOF;
2011 else 2023 else
2012 return *pt->rep.string.curr++; 2024 return *pt->rep.string.curr++;
2013 } 2025 }
2014#else 2026#else
2015 if (ungot == -1)
2016 {
2017 char c; 2027 char c;
2018 if (!read (0, &c, 1)) 2028
2029 if (!read (pt->rep.stdio.file, &c, 1))
2019 return EOF; 2030 return EOF;
2020 2031
2021 ungot = c;
2022 }
2023
2024 {
2025 int r = ungot;
2026 ungot = -1;
2027 return r; 2032 return c;
2028 }
2029#endif 2033#endif
2030} 2034}
2031 2035
2032/* back character to input buffer */ 2036/* back character to input buffer */
2033static void 2037ecb_cold static void
2034backchar (SCHEME_P_ int c) 2038backchar (SCHEME_P_ int c)
2035{ 2039{
2036#if USE_PORTS 2040 port *pt = port (SCHEME_V->inport);
2037 port *pt;
2038 2041
2039 if (c == EOF) 2042 if (c == EOF)
2040 return; 2043 return;
2041 2044
2042 pt = port (SCHEME_V->inport);
2043 pt->unget = c; 2045 pt->unget = c;
2044#else
2045 if (c == EOF)
2046 return;
2047
2048 ungot = c;
2049#endif
2050} 2046}
2051 2047
2052#if USE_PORTS 2048#if USE_PORTS
2053static int 2049ecb_cold static int
2054realloc_port_string (SCHEME_P_ port *p) 2050realloc_port_string (SCHEME_P_ port *p)
2055{ 2051{
2056 char *start = p->rep.string.start; 2052 char *start = p->rep.string.start;
2057 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;
2058 char *str = malloc (new_size); 2054 char *str = malloc (new_size);
… …
2071 else 2067 else
2072 return 0; 2068 return 0;
2073} 2069}
2074#endif 2070#endif
2075 2071
2076INTERFACE void 2072ecb_cold static void
2077putstr (SCHEME_P_ const char *s) 2073putchars (SCHEME_P_ const char *s, int len)
2078{ 2074{
2075 port *pt = port (SCHEME_V->outport);
2076
2079#if USE_PORTS 2077#if USE_PORTS
2080 port *pt = port (SCHEME_V->outport);
2081
2082 if (pt->kind & port_file)
2083 write (pt->rep.stdio.file, s, strlen (s));
2084 else
2085 for (; *s; s++)
2086 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2087 *pt->rep.string.curr++ = *s;
2088 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2089 *pt->rep.string.curr++ = *s;
2090
2091#else
2092 write (pt->rep.stdio.file, s, strlen (s));
2093#endif
2094}
2095
2096static void
2097putchars (SCHEME_P_ const char *s, int len)
2098{
2099#if USE_PORTS
2100 port *pt = port (SCHEME_V->outport);
2101
2102 if (pt->kind & port_file) 2078 if (pt->kind & port_file)
2103 write (pt->rep.stdio.file, s, len); 2079 write (pt->rep.stdio.file, s, len);
2104 else 2080 else
2105 { 2081 {
2106 for (; len; len--) 2082 for (; len; len--)
… …
2111 *pt->rep.string.curr++ = *s++; 2087 *pt->rep.string.curr++ = *s++;
2112 } 2088 }
2113 } 2089 }
2114 2090
2115#else 2091#else
2116 write (1, s, len); 2092 write (1, s, len); // output not initialised
2117#endif 2093#endif
2094}
2095
2096INTERFACE void
2097putstr (SCHEME_P_ const char *s)
2098{
2099 putchars (SCHEME_A_ s, strlen (s));
2118} 2100}
2119 2101
2120INTERFACE void 2102INTERFACE void
2121putcharacter (SCHEME_P_ int c) 2103putcharacter (SCHEME_P_ int c)
2122{ 2104{
2123#if USE_PORTS
2124 port *pt = port (SCHEME_V->outport);
2125
2126 if (pt->kind & port_file)
2127 {
2128 char cc = c;
2129 write (pt->rep.stdio.file, &cc, 1);
2130 }
2131 else
2132 {
2133 if (pt->rep.string.curr != pt->rep.string.past_the_end)
2134 *pt->rep.string.curr++ = c;
2135 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2136 *pt->rep.string.curr++ = c;
2137 }
2138
2139#else
2140 char cc = c; 2105 char cc = c;
2141 write (1, &c, 1); 2106
2142#endif 2107 putchars (SCHEME_A_ &cc, 1);
2143} 2108}
2144 2109
2145/* read characters up to delimiter, but cater to character constants */ 2110/* read characters up to delimiter, but cater to character constants */
2146static char * 2111ecb_cold static char *
2147readstr_upto (SCHEME_P_ int skip, const char *delim) 2112readstr_upto (SCHEME_P_ int skip, const char *delim)
2148{ 2113{
2149 char *p = SCHEME_V->strbuff + skip; 2114 char *p = SCHEME_V->strbuff + skip;
2150 2115
2151 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))));
… …
2160 2125
2161 return SCHEME_V->strbuff; 2126 return SCHEME_V->strbuff;
2162} 2127}
2163 2128
2164/* read string expression "xxx...xxx" */ 2129/* read string expression "xxx...xxx" */
2165static pointer 2130ecb_cold static pointer
2166readstrexp (SCHEME_P_ char delim) 2131readstrexp (SCHEME_P_ char delim)
2167{ 2132{
2168 char *p = SCHEME_V->strbuff; 2133 char *p = SCHEME_V->strbuff;
2169 int c; 2134 int c;
2170 int c1 = 0; 2135 int c1 = 0;
… …
2203 case '7': 2168 case '7':
2204 state = st_oct1; 2169 state = st_oct1;
2205 c1 = c - '0'; 2170 c1 = c - '0';
2206 break; 2171 break;
2207 2172
2173 case 'a': *p++ = '\a'; state = st_ok; break;
2174 case 'n': *p++ = '\n'; state = st_ok; break;
2175 case 'r': *p++ = '\r'; state = st_ok; break;
2176 case 't': *p++ = '\t'; state = st_ok; break;
2177
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;
2186
2187 //TODO: x should end in ;, not two-digit hex
2208 case 'x': 2188 case 'x':
2209 case 'X': 2189 case 'X':
2210 state = st_x1; 2190 state = st_x1;
2211 c1 = 0; 2191 c1 = 0;
2212 break;
2213
2214 case 'n':
2215 *p++ = '\n';
2216 state = st_ok;
2217 break;
2218
2219 case 't':
2220 *p++ = '\t';
2221 state = st_ok;
2222 break;
2223
2224 case 'r':
2225 *p++ = '\r';
2226 state = st_ok;
2227 break; 2192 break;
2228 2193
2229 default: 2194 default:
2230 *p++ = c; 2195 *p++ = c;
2231 state = st_ok; 2196 state = st_ok;
… …
2283 } 2248 }
2284 } 2249 }
2285} 2250}
2286 2251
2287/* check c is in chars */ 2252/* check c is in chars */
2288ecb_inline int 2253ecb_cold int
2289is_one_of (const char *s, int c) 2254is_one_of (const char *s, int c)
2290{ 2255{
2291 return c == EOF || !!strchr (s, c); 2256 return c == EOF || !!strchr (s, c);
2292} 2257}
2293 2258
2294/* skip white characters */ 2259/* skip white characters */
2295ecb_inline int 2260ecb_cold int
2296skipspace (SCHEME_P) 2261skipspace (SCHEME_P)
2297{ 2262{
2298 int c, curr_line = 0; 2263 int c, curr_line = 0;
2299 2264
2300 do 2265 do
… …
2320 backchar (SCHEME_A_ c); 2285 backchar (SCHEME_A_ c);
2321 return 1; 2286 return 1;
2322} 2287}
2323 2288
2324/* get token */ 2289/* get token */
2325static int 2290ecb_cold static int
2326token (SCHEME_P) 2291token (SCHEME_P)
2327{ 2292{
2328 int c = skipspace (SCHEME_A); 2293 int c = skipspace (SCHEME_A);
2329 2294
2330 if (c == EOF) 2295 if (c == EOF)
… …
2428} 2393}
2429 2394
2430/* ========== Routines for Printing ========== */ 2395/* ========== Routines for Printing ========== */
2431#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL) 2396#define ok_abbrev(x) (is_pair(x) && cdr(x) == NIL)
2432 2397
2433static void 2398ecb_cold static void
2434printslashstring (SCHEME_P_ char *p, int len) 2399printslashstring (SCHEME_P_ char *p, int len)
2435{ 2400{
2436 int i; 2401 int i;
2437 unsigned char *s = (unsigned char *) p; 2402 unsigned char *s = (unsigned char *) p;
2438 2403
… …
2494 2459
2495 putcharacter (SCHEME_A_ '"'); 2460 putcharacter (SCHEME_A_ '"');
2496} 2461}
2497 2462
2498/* print atoms */ 2463/* print atoms */
2499static void 2464ecb_cold static void
2500printatom (SCHEME_P_ pointer l, int f) 2465printatom (SCHEME_P_ pointer l, int f)
2501{ 2466{
2502 char *p; 2467 char *p;
2503 int len; 2468 int len;
2504 2469
2505 atom2str (SCHEME_A_ l, f, &p, &len); 2470 atom2str (SCHEME_A_ l, f, &p, &len);
2506 putchars (SCHEME_A_ p, len); 2471 putchars (SCHEME_A_ p, len);
2507} 2472}
2508 2473
2509/* Uses internal buffer unless string pointer is already available */ 2474/* Uses internal buffer unless string pointer is already available */
2510static void 2475ecb_cold static void
2511atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen) 2476atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
2512{ 2477{
2513 char *p; 2478 char *p;
2514 2479
2515 if (l == NIL) 2480 if (l == NIL)
… …
2648 } 2613 }
2649 else if (is_symbol (l)) 2614 else if (is_symbol (l))
2650 p = symname (l); 2615 p = symname (l);
2651 else if (is_proc (l)) 2616 else if (is_proc (l))
2652 { 2617 {
2618 p = (char *)procname (l); // ok with r7rs display, but not r7rs write
2619#if 0
2653#if USE_PRINTF 2620#if USE_PRINTF
2654 p = SCHEME_V->strbuff; 2621 p = SCHEME_V->strbuff;
2655 snprintf (p, STRBUFFSIZE, "#<%s PROCEDURE %ld>", procname (l), procnum (l)); 2622 snprintf (p, STRBUFFSIZE, " PROCEDURE %ld>", procname (l), procnum (l));
2656#else 2623#else
2657 p = "#<PROCEDURE>"; 2624 p = "#<PROCEDURE>";
2625#endif
2658#endif 2626#endif
2659 } 2627 }
2660 else if (is_macro (l)) 2628 else if (is_macro (l))
2661 p = "#<MACRO>"; 2629 p = "#<MACRO>";
2662 else if (is_closure (l)) 2630 else if (is_closure (l))
… …
2722 return car (d); 2690 return car (d);
2723 2691
2724 p = cons (car (d), cdr (d)); 2692 p = cons (car (d), cdr (d));
2725 q = p; 2693 q = p;
2726 2694
2727 while (cdr (cdr (p)) != NIL) 2695 while (cddr (p) != NIL)
2728 { 2696 {
2729 d = cons (car (p), cdr (p)); 2697 d = cons (car (p), cdr (p));
2730 2698
2731 if (cdr (cdr (p)) != NIL) 2699 if (cddr (p) != NIL)
2732 p = cdr (d); 2700 p = cdr (d);
2733 } 2701 }
2734 2702
2735 set_cdr (p, car (cdr (p))); 2703 set_cdr (p, cadr (p));
2736 return q; 2704 return q;
2737} 2705}
2738 2706
2739/* reverse list -- produce new list */ 2707/* reverse list -- produce new list */
2740static pointer 2708ecb_hot static pointer
2741reverse (SCHEME_P_ pointer a) 2709reverse (SCHEME_P_ pointer a)
2742{ 2710{
2743 /* a must be checked by gc */ 2711 /* a must be checked by gc */
2744 pointer p = NIL; 2712 pointer p = NIL;
2745 2713
… …
2748 2716
2749 return p; 2717 return p;
2750} 2718}
2751 2719
2752/* reverse list --- in-place */ 2720/* reverse list --- in-place */
2753static pointer 2721ecb_hot static pointer
2754reverse_in_place (SCHEME_P_ pointer term, pointer list) 2722reverse_in_place (SCHEME_P_ pointer term, pointer list)
2755{ 2723{
2756 pointer result = term; 2724 pointer result = term;
2757 pointer p = list; 2725 pointer p = list;
2758 2726
… …
2766 2734
2767 return result; 2735 return result;
2768} 2736}
2769 2737
2770/* append list -- produce new list (in reverse order) */ 2738/* append list -- produce new list (in reverse order) */
2771static pointer 2739ecb_hot static pointer
2772revappend (SCHEME_P_ pointer a, pointer b) 2740revappend (SCHEME_P_ pointer a, pointer b)
2773{ 2741{
2774 pointer result = a; 2742 pointer result = a;
2775 pointer p = b; 2743 pointer p = b;
2776 2744
… …
2785 2753
2786 return S_F; /* signal an error */ 2754 return S_F; /* signal an error */
2787} 2755}
2788 2756
2789/* equivalence of atoms */ 2757/* equivalence of atoms */
2790int 2758ecb_hot int
2791eqv (pointer a, pointer b) 2759eqv (pointer a, pointer b)
2792{ 2760{
2793 if (is_string (a)) 2761 if (is_string (a))
2794 { 2762 {
2795 if (is_string (b)) 2763 if (is_string (b))
… …
2889 } 2857 }
2890 else 2858 else
2891 set_car (env, immutable_cons (slot, car (env))); 2859 set_car (env, immutable_cons (slot, car (env)));
2892} 2860}
2893 2861
2894static pointer 2862ecb_hot static pointer
2895find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2863find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2896{ 2864{
2897 pointer x, y; 2865 pointer x, y;
2898 2866
2899 for (x = env; x != NIL; x = cdr (x)) 2867 for (x = env; x != NIL; x = cdr (x))
… …
2920 return NIL; 2888 return NIL;
2921} 2889}
2922 2890
2923#else /* USE_ALIST_ENV */ 2891#else /* USE_ALIST_ENV */
2924 2892
2925ecb_inline void 2893static void
2926new_frame_in_env (SCHEME_P_ pointer old_env) 2894new_frame_in_env (SCHEME_P_ pointer old_env)
2927{ 2895{
2928 SCHEME_V->envir = immutable_cons (NIL, old_env); 2896 SCHEME_V->envir = immutable_cons (NIL, old_env);
2929 setenvironment (SCHEME_V->envir); 2897 setenvironment (SCHEME_V->envir);
2930} 2898}
2931 2899
2932ecb_inline void 2900static void
2933new_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)
2934{ 2902{
2935 set_car (env, immutable_cons (immutable_cons (variable, value), car (env))); 2903 set_car (env, immutable_cons (immutable_cons (variable, value), car (env)));
2936} 2904}
2937 2905
2938static pointer 2906ecb_hot static pointer
2939find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all) 2907find_slot_in_env (SCHEME_P_ pointer env, pointer hdl, int all)
2940{ 2908{
2941 pointer x, y; 2909 pointer x, y;
2942 2910
2943 for (x = env; x != NIL; x = cdr (x)) 2911 for (x = env; x != NIL; x = cdr (x))
… …
2957 return NIL; 2925 return NIL;
2958} 2926}
2959 2927
2960#endif /* USE_ALIST_ENV else */ 2928#endif /* USE_ALIST_ENV else */
2961 2929
2962ecb_inline void 2930static void
2963new_slot_in_env (SCHEME_P_ pointer variable, pointer value) 2931new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
2964{ 2932{
2965 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2 2933 assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
2966 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);
2967} 2935}
2968 2936
2969ecb_inline void 2937static void
2970set_slot_in_env (SCHEME_P_ pointer slot, pointer value) 2938set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
2971{ 2939{
2972 set_cdr (slot, value); 2940 set_cdr (slot, value);
2973} 2941}
2974 2942
2975ecb_inline pointer 2943static pointer
2976slot_value_in_env (pointer slot) 2944slot_value_in_env (pointer slot)
2977{ 2945{
2978 return cdr (slot); 2946 return cdr (slot);
2979} 2947}
2980 2948
2981/* ========== Evaluation Cycle ========== */ 2949/* ========== Evaluation Cycle ========== */
2982 2950
2983static int 2951ecb_cold static int
2984xError_1 (SCHEME_P_ const char *s, pointer a) 2952xError_1 (SCHEME_P_ const char *s, pointer a)
2985{ 2953{
2986#if USE_ERROR_HOOK
2987 pointer x;
2988 pointer hdl = SCHEME_V->ERROR_HOOK;
2989#endif
2990
2991#if USE_PRINTF 2954#if USE_PRINTF
2992#if SHOW_ERROR_LINE 2955#if SHOW_ERROR_LINE
2993 char sbuf[STRBUFFSIZE]; 2956 char sbuf[STRBUFFSIZE];
2994 2957
2995 /* make sure error is not in REPL */ 2958 /* make sure error is not in REPL */
… …
3010 } 2973 }
3011#endif 2974#endif
3012#endif 2975#endif
3013 2976
3014#if USE_ERROR_HOOK 2977#if USE_ERROR_HOOK
3015 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);
3016 2979
3017 if (x != NIL) 2980 if (x != NIL)
3018 { 2981 {
3019 pointer code = a 2982 pointer code = a
3020 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL) 2983 ? cons (cons (SCHEME_V->QUOTE, cons (a, NIL)), NIL)
… …
3064 pointer code; 3027 pointer code;
3065}; 3028};
3066 3029
3067# define STACK_GROWTH 3 3030# define STACK_GROWTH 3
3068 3031
3069static void 3032ecb_hot static void
3070s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3033s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3071{ 3034{
3072 int nframes = (uintptr_t)SCHEME_V->dump; 3035 int nframes = (uintptr_t)SCHEME_V->dump;
3073 struct dump_stack_frame *next_frame; 3036 struct dump_stack_frame *next_frame;
3074 3037
… …
3087 next_frame->code = code; 3050 next_frame->code = code;
3088 3051
3089 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1); 3052 SCHEME_V->dump = (pointer)(uintptr_t)(nframes + 1);
3090} 3053}
3091 3054
3092static int 3055static ecb_hot int
3093xs_return (SCHEME_P_ pointer a) 3056xs_return (SCHEME_P_ pointer a)
3094{ 3057{
3095 int nframes = (uintptr_t)SCHEME_V->dump; 3058 int nframes = (uintptr_t)SCHEME_V->dump;
3096 struct dump_stack_frame *frame; 3059 struct dump_stack_frame *frame;
3097 3060
… …
3108 SCHEME_V->dump = (pointer)(uintptr_t)nframes; 3071 SCHEME_V->dump = (pointer)(uintptr_t)nframes;
3109 3072
3110 return 0; 3073 return 0;
3111} 3074}
3112 3075
3113ecb_inline void 3076ecb_cold void
3114dump_stack_reset (SCHEME_P) 3077dump_stack_reset (SCHEME_P)
3115{ 3078{
3116 /* 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 */
3117 SCHEME_V->dump = (pointer)+0; 3080 SCHEME_V->dump = (pointer)+0;
3118} 3081}
3119 3082
3120ecb_inline void 3083ecb_cold void
3121dump_stack_initialize (SCHEME_P) 3084dump_stack_initialize (SCHEME_P)
3122{ 3085{
3123 SCHEME_V->dump_size = 0; 3086 SCHEME_V->dump_size = 0;
3124 SCHEME_V->dump_base = 0; 3087 SCHEME_V->dump_base = 0;
3125 dump_stack_reset (SCHEME_A); 3088 dump_stack_reset (SCHEME_A);
3126} 3089}
3127 3090
3128static void 3091ecb_cold static void
3129dump_stack_free (SCHEME_P) 3092dump_stack_free (SCHEME_P)
3130{ 3093{
3131 free (SCHEME_V->dump_base); 3094 free (SCHEME_V->dump_base);
3132 SCHEME_V->dump_base = 0; 3095 SCHEME_V->dump_base = 0;
3133 SCHEME_V->dump = (pointer)0; 3096 SCHEME_V->dump = (pointer)0;
3134 SCHEME_V->dump_size = 0; 3097 SCHEME_V->dump_size = 0;
3135} 3098}
3136 3099
3137static void 3100ecb_cold static void
3138dump_stack_mark (SCHEME_P) 3101dump_stack_mark (SCHEME_P)
3139{ 3102{
3140 int nframes = (uintptr_t)SCHEME_V->dump; 3103 int nframes = (uintptr_t)SCHEME_V->dump;
3141 int i; 3104 int i;
3142 3105
… …
3148 mark (frame->envir); 3111 mark (frame->envir);
3149 mark (frame->code); 3112 mark (frame->code);
3150 } 3113 }
3151} 3114}
3152 3115
3153static pointer 3116ecb_cold static pointer
3154ss_get_cont (SCHEME_P) 3117ss_get_cont (SCHEME_P)
3155{ 3118{
3156 int nframes = (uintptr_t)SCHEME_V->dump; 3119 int nframes = (uintptr_t)SCHEME_V->dump;
3157 int i; 3120 int i;
3158 3121
… …
3170 } 3133 }
3171 3134
3172 return cont; 3135 return cont;
3173} 3136}
3174 3137
3175static void 3138ecb_cold static void
3176ss_set_cont (SCHEME_P_ pointer cont) 3139ss_set_cont (SCHEME_P_ pointer cont)
3177{ 3140{
3178 int i = 0; 3141 int i = 0;
3179 struct dump_stack_frame *frame = SCHEME_V->dump_base; 3142 struct dump_stack_frame *frame = SCHEME_V->dump_base;
3180 3143
… …
3192 SCHEME_V->dump = (pointer)(uintptr_t)i; 3155 SCHEME_V->dump = (pointer)(uintptr_t)i;
3193} 3156}
3194 3157
3195#else 3158#else
3196 3159
3197ecb_inline void 3160ecb_cold void
3198dump_stack_reset (SCHEME_P) 3161dump_stack_reset (SCHEME_P)
3199{ 3162{
3200 SCHEME_V->dump = NIL; 3163 SCHEME_V->dump = NIL;
3201} 3164}
3202 3165
3203ecb_inline void 3166ecb_cold void
3204dump_stack_initialize (SCHEME_P) 3167dump_stack_initialize (SCHEME_P)
3205{ 3168{
3206 dump_stack_reset (SCHEME_A); 3169 dump_stack_reset (SCHEME_A);
3207} 3170}
3208 3171
3209static void 3172ecb_cold static void
3210dump_stack_free (SCHEME_P) 3173dump_stack_free (SCHEME_P)
3211{ 3174{
3212 SCHEME_V->dump = NIL; 3175 SCHEME_V->dump = NIL;
3213} 3176}
3214 3177
3215static int 3178ecb_hot static int
3216xs_return (SCHEME_P_ pointer a) 3179xs_return (SCHEME_P_ pointer a)
3217{ 3180{
3218 pointer dump = SCHEME_V->dump; 3181 pointer dump = SCHEME_V->dump;
3219 3182
3220 SCHEME_V->value = a; 3183 SCHEME_V->value = a;
… …
3230 SCHEME_V->dump = dump; 3193 SCHEME_V->dump = dump;
3231 3194
3232 return 0; 3195 return 0;
3233} 3196}
3234 3197
3235static void 3198ecb_hot static void
3236s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code) 3199s_save (SCHEME_P_ enum scheme_opcodes op, pointer args, pointer code)
3237{ 3200{
3238 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op), 3201 SCHEME_V->dump = cons (mk_integer (SCHEME_A_ op),
3239 cons (args, 3202 cons (args,
3240 cons (SCHEME_V->envir, 3203 cons (SCHEME_V->envir,
3241 cons (code, 3204 cons (code,
3242 SCHEME_V->dump)))); 3205 SCHEME_V->dump))));
3243} 3206}
3244 3207
3245static void 3208ecb_cold static void
3246dump_stack_mark (SCHEME_P) 3209dump_stack_mark (SCHEME_P)
3247{ 3210{
3248 mark (SCHEME_V->dump); 3211 mark (SCHEME_V->dump);
3249} 3212}
3250 3213
3251static pointer 3214ecb_cold static pointer
3252ss_get_cont (SCHEME_P) 3215ss_get_cont (SCHEME_P)
3253{ 3216{
3254 return SCHEME_V->dump; 3217 return SCHEME_V->dump;
3255} 3218}
3256 3219
3257static void 3220ecb_cold static void
3258ss_set_cont (SCHEME_P_ pointer cont) 3221ss_set_cont (SCHEME_P_ pointer cont)
3259{ 3222{
3260 SCHEME_V->dump = cont; 3223 SCHEME_V->dump = cont;
3261} 3224}
3262 3225
3263#endif 3226#endif
3264 3227
3265#define s_retbool(tf) s_return ((tf) ? S_T : S_F) 3228#define s_retbool(tf) s_return ((tf) ? S_T : S_F)
3266 3229
3267#if EXPERIMENT 3230#if EXPERIMENT
3231
3268static int 3232static int
3269debug (SCHEME_P_ int indent, pointer x) 3233dtree (SCHEME_P_ int indent, pointer x)
3270{ 3234{
3271 int c; 3235 int c;
3272 3236
3273 if (is_syntax (x)) 3237 if (is_syntax (x))
3274 { 3238 {
… …
3292 printf ("%*sS<%s>\n", indent, "", symname (x)); 3256 printf ("%*sS<%s>\n", indent, "", symname (x));
3293 return 24+8; 3257 return 24+8;
3294 3258
3295 case T_CLOSURE: 3259 case T_CLOSURE:
3296 printf ("%*sS<%s>\n", indent, "", "closure"); 3260 printf ("%*sS<%s>\n", indent, "", "closure");
3297 debug (SCHEME_A_ indent + 3, cdr(x)); 3261 dtree (SCHEME_A_ indent + 3, cdr(x));
3298 return 32 + debug (SCHEME_A_ indent + 3, car (x)); 3262 return 32 + dtree (SCHEME_A_ indent + 3, car (x));
3299 3263
3300 case T_PAIR: 3264 case T_PAIR:
3301 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x)); 3265 printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
3302 c = debug (SCHEME_A_ indent + 3, car (x)); 3266 c = dtree (SCHEME_A_ indent + 3, car (x));
3303 c += debug (SCHEME_A_ indent + 3, cdr (x)); 3267 c += dtree (SCHEME_A_ indent + 3, cdr (x));
3304 return c + 1; 3268 return c + 1;
3305 3269
3306 case T_PORT: 3270 case T_PORT:
3307 printf ("%*sS<%s>\n", indent, "", "port"); 3271 printf ("%*sS<%s>\n", indent, "", "port");
3308 return 24+8; 3272 return 24+8;
… …
3311 printf ("%*sS<%s>\n", indent, "", "vector"); 3275 printf ("%*sS<%s>\n", indent, "", "vector");
3312 return 24+8; 3276 return 24+8;
3313 3277
3314 case T_ENVIRONMENT: 3278 case T_ENVIRONMENT:
3315 printf ("%*sS<%s>\n", indent, "", "environment"); 3279 printf ("%*sS<%s>\n", indent, "", "environment");
3316 return 0 + debug (SCHEME_A_ indent + 3, car (x)); 3280 return 0 + dtree (SCHEME_A_ indent + 3, car (x));
3317 3281
3318 default: 3282 default:
3319 printf ("unhandled type %d\n", type (x)); 3283 printf ("unhandled type %d\n", type (x));
3320 break; 3284 break;
3321 } 3285 }
3322} 3286}
3323#endif
3324 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_OP,
3400};
3401
3402ecb_cold static void compile_expr (SCHEME_P_ stream s, pointer x);
3403
3404ecb_cold static void
3405compile_list (SCHEME_P_ stream s, pointer x)
3406{
3407 // TODO: improper list
3408
3409 for (; x != NIL; x = cdr (x))
3410 {
3411 stream t = stream_init ();
3412 compile_expr (SCHEME_A_ t, car (x));
3413 stream_put_v (s, stream_size (t));
3414 stream_put_stream (s, t);
3415 }
3416
3417 stream_put_v (s, 0);
3418}
3419
3420static void
3421compile_if (SCHEME_P_ stream s, pointer cond, pointer ift, pointer iff)
3422{
3423 stream sift = stream_init (); compile_expr (SCHEME_A_ sift, ift);
3424
3425 stream_put (s, BOP_IF);
3426 compile_expr (SCHEME_A_ s, cond);
3427 stream_put_v (s, stream_size (sift));
3428 stream_put_stream (s, sift);
3429 compile_expr (SCHEME_A_ s, iff);
3430}
3431
3432typedef uint32_t stream_fixup;
3433
3434static stream_fixup
3435stream_put_fixup (stream s)
3436{
3437 stream_put (s, 0);
3438 stream_put (s, 0);
3439
3440 return stream_size (s);
3441}
3442
3443static void
3444stream_fix_fixup (stream s, stream_fixup fixup, uint32_t target)
3445{
3446 target -= fixup;
3447 assert (target < (1 << 14));
3448 stream_data (s)[fixup - 2] = target | 0x80;
3449 stream_data (s)[fixup - 1] = target >> 7;
3450}
3451
3452static void
3453compile_and_or (SCHEME_P_ stream s, int and, pointer x)
3454{
3455 for (; cdr (x) != NIL; x = cdr (x))
3456 {
3457 stream t = stream_init ();
3458 compile_expr (SCHEME_A_ t, car (x));
3459 stream_put_v (s, stream_size (t));
3460 stream_put_stream (s, t);
3461 }
3462
3463 stream_put_v (s, 0);
3464}
3465
3466static void
3467compile_case (SCHEME_P_ stream s, pointer x)
3468{
3469 compile_expr (SCHEME_A_ s, caar (x));
3470
3471 for (;;)
3472 {
3473 x = cdr (x);
3474
3475 if (x == NIL)
3476 break;
3477
3478 compile_expr (SCHEME_A_ s, caar (x));
3479 stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
3480 stream_put_v (s, stream_size (t));
3481 stream_put_stream (s, t);
3482 }
3483
3484 stream_put_v (s, 0);
3485}
3486
3487static void
3488compile_cond (SCHEME_P_ stream s, pointer x)
3489{
3490 for ( ; x != NIL; x = cdr (x))
3491 {
3492 compile_expr (SCHEME_A_ s, caar (x));
3493 stream t = stream_init (); compile_expr (SCHEME_A_ t, cdar (x));
3494 stream_put_v (s, stream_size (t));
3495 stream_put_stream (s, t);
3496 }
3497
3498 stream_put_v (s, 0);
3499}
3500
3325static int 3501static pointer
3502lookup (SCHEME_P_ pointer x)
3503{
3504 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, x, 1);
3505
3506 if (x != NIL)
3507 x = slot_value_in_env (x);
3508
3509 return x;
3510}
3511
3512ecb_cold static void
3513compile_expr (SCHEME_P_ stream s, pointer x)
3514{
3515 if (x == NIL)
3516 {
3517 stream_put (s, BOP_NIL);
3518 return;
3519 }
3520
3521 if (is_pair (x))
3522 {
3523 pointer head = car (x);
3524
3525 if (is_syntax (head))
3526 {
3527 x = cdr (x);
3528
3529 switch (syntaxnum (head))
3530 {
3531 case OP_IF0: /* if */
3532 stream_put_v (s, BOP_IF);
3533 compile_if (SCHEME_A_ s, car (x), cadr (x), caddr (x));
3534 break;
3535
3536 case OP_OR0: /* or */
3537 stream_put_v (s, BOP_OR);
3538 compile_and_or (SCHEME_A_ s, 0, x);
3539 break;
3540
3541 case OP_AND0: /* and */
3542 stream_put_v (s, BOP_AND);
3543 compile_and_or (SCHEME_A_ s, 1, x);
3544 break;
3545
3546 case OP_CASE0: /* case */
3547 stream_put_v (s, BOP_CASE);
3548 compile_case (SCHEME_A_ s, x);
3549 break;
3550
3551 case OP_COND0: /* cond */
3552 stream_put_v (s, BOP_COND);
3553 compile_cond (SCHEME_A_ s, x);
3554 break;
3555
3556 case OP_LET0: /* let */
3557 case OP_LET0AST: /* let* */
3558 case OP_LET0REC: /* letrec */
3559 switch (syntaxnum (head))
3560 {
3561 case OP_LET0: stream_put (s, BOP_LET ); break;
3562 case OP_LET0AST: stream_put (s, BOP_LETAST); break;
3563 case OP_LET0REC: stream_put (s, BOP_LETREC); break;
3564 }
3565
3566 {
3567 pointer bindings = car (x);
3568 pointer body = cadr (x);
3569
3570 for (x = bindings; x != NIL; x = cdr (x))
3571 {
3572 pointer init = NIL;
3573 pointer var = car (x);
3574
3575 if (is_pair (var))
3576 {
3577 init = cdr (var);
3578 var = car (var);
3579 }
3580
3581 stream_put_v (s, symbol_id (SCHEME_A_ var));
3582 compile_expr (SCHEME_A_ s, init);
3583 }
3584
3585 stream_put_v (s, 0);
3586 compile_expr (SCHEME_A_ s, body);
3587 }
3588 break;
3589
3590 case OP_DEF0: /* define */
3591 case OP_MACRO0: /* macro */
3592 stream_put (s, syntaxnum (head) == OP_DEF0 ? BOP_DEFINE : BOP_MACRO);
3593 stream_put_v (s, cell_id (SCHEME_A_ car (x)));
3594 compile_expr (SCHEME_A_ s, cadr (x));
3595 break;
3596
3597 case OP_SET0: /* set! */
3598 stream_put (s, BOP_SET);
3599 stream_put_v (s, symbol_id (SCHEME_A_ car (x)));
3600 compile_expr (SCHEME_A_ s, cadr (x));
3601 break;
3602
3603 case OP_BEGIN: /* begin */
3604 stream_put (s, BOP_BEGIN);
3605 compile_list (SCHEME_A_ s, x);
3606 return;
3607
3608 case OP_DELAY: /* delay */
3609 abort ();
3610 break;
3611
3612 case OP_QUOTE: /* quote */
3613 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3614 break;
3615
3616 case OP_LAMBDA: /* lambda */
3617 {
3618 pointer formals = car (x);
3619 pointer body = cadr (x);
3620
3621 stream_put (s, BOP_LAMBDA);
3622
3623 for (; is_pair (formals); formals = cdr (formals))
3624 stream_put_v (s, symbol_id (SCHEME_A_ car (formals)));
3625
3626 stream_put_v (s, 0);
3627 stream_put_v (s, formals == NIL ? 0 : symbol_id (SCHEME_A_ formals));
3628
3629 compile_expr (SCHEME_A_ s, body);
3630 }
3631 break;
3632
3633 case OP_C0STREAM:/* cons-stream */
3634 abort ();
3635 break;
3636 }
3637
3638 return;
3639 }
3640
3641 pointer m = lookup (SCHEME_A_ head);
3642
3643 if (is_macro (m))
3644 {
3645 s_save (SCHEME_A_ OP_DEBUG2, SCHEME_V->args, SCHEME_V->code);
3646 SCHEME_V->code = m;
3647 SCHEME_V->args = cons (x, NIL);
3648 Eval_Cycle (SCHEME_A_ OP_APPLY);
3649 x = SCHEME_V->value;
3650 compile_expr (SCHEME_A_ s, SCHEME_V->value);
3651 return;
3652 }
3653
3654 stream_put (s, BOP_LIST_BEG);
3655
3656 for (; x != NIL; x = cdr (x))
3657 compile_expr (SCHEME_A_ s, car (x));
3658
3659 stream_put (s, BOP_LIST_END);
3660 return;
3661 }
3662
3663 switch (type (x))
3664 {
3665 case T_INTEGER:
3666 {
3667 IVALUE iv = ivalue_unchecked (x);
3668 iv = iv < 0 ? ((~(uint32_t)iv) << 1) | 1 : (uint32_t)iv << 1;
3669 stream_put_tv (s, BOP_INTEGER, iv);
3670 }
3671 return;
3672
3673 case T_SYMBOL:
3674 if (0)
3675 {
3676 // no can do without more analysis
3677 pointer m = lookup (SCHEME_A_ x);
3678
3679 if (is_proc (m))
3680 {
3681 printf ("compile proc %s %d\n", procname(m), procnum(m));
3682 stream_put_tv (s, BOP_SYMBOL, BOP_OP + procnum (m));
3683 }
3684 else
3685 stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3686 }
3687
3688 stream_put_tv (s, BOP_SYMBOL, symbol_id (SCHEME_A_ x));
3689 return;
3690
3691 default:
3692 stream_put_tv (s, BOP_DATUM, cell_id (SCHEME_A_ x));
3693 break;
3694 }
3695}
3696
3697ecb_cold static int
3698compile_closure (SCHEME_P_ pointer p)
3699{
3700 stream s = stream_init ();
3701
3702 compile_list (SCHEME_A_ s, cdar (p));
3703
3704 FILE *xxd = popen ("xxd", "we");
3705 fwrite (stream_data (s), 1, stream_size (s), xxd);
3706 fclose (xxd);
3707
3708 return stream_size (s);
3709}
3710
3711#endif
3712
3713/* syntax, eval, core, ... */
3714ecb_hot static int
3326opexe_0 (SCHEME_P_ enum scheme_opcodes op) 3715opexe_0 (SCHEME_P_ enum scheme_opcodes op)
3327{ 3716{
3328 pointer args = SCHEME_V->args; 3717 pointer args = SCHEME_V->args;
3329 pointer x, y; 3718 pointer x, y;
3330 3719
3331 switch (op) 3720 switch (op)
3332 { 3721 {
3333#if EXPERIMENT //D 3722#if EXPERIMENT //D
3334 case OP_DEBUG: 3723 case OP_DEBUG:
3335 printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8); 3724 {
3725 uint32_t len = compile_closure (SCHEME_A_ car (args));
3726 printf ("len = %d\n", len);
3336 printf ("\n"); 3727 printf ("\n");
3337 s_return (S_T); 3728 s_return (S_T);
3729 }
3730
3731 case OP_DEBUG2:
3732 return -1;
3338#endif 3733#endif
3734
3339 case OP_LOAD: /* load */ 3735 case OP_LOAD: /* load */
3340 if (file_interactive (SCHEME_A)) 3736 if (file_interactive (SCHEME_A))
3341 { 3737 {
3342 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n"); 3738 putstr (SCHEME_A_ "Loading ");
3343 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3739 putstr (SCHEME_A_ strvalue (car (args)));
3740 putcharacter (SCHEME_A_ '\n');
3344 } 3741 }
3345 3742
3346 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3743 if (!file_push (SCHEME_A_ strvalue (car (args))))
3347 Error_1 ("unable to open", car (args)); 3744 Error_1 ("unable to open", car (args));
3348 else 3745
3349 {
3350 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 3746 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
3351 s_goto (OP_T0LVL); 3747 s_goto (OP_T0LVL);
3352 }
3353 3748
3354 case OP_T0LVL: /* top level */ 3749 case OP_T0LVL: /* top level */
3355 3750
3356 /* If we reached the end of file, this loop is done. */ 3751 /* If we reached the end of file, this loop is done. */
3357 if (port (SCHEME_V->loadport)->kind & port_saw_EOF) 3752 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
… …
3373 /* If interactive, be nice to user. */ 3768 /* If interactive, be nice to user. */
3374 if (file_interactive (SCHEME_A)) 3769 if (file_interactive (SCHEME_A))
3375 { 3770 {
3376 SCHEME_V->envir = SCHEME_V->global_env; 3771 SCHEME_V->envir = SCHEME_V->global_env;
3377 dump_stack_reset (SCHEME_A); 3772 dump_stack_reset (SCHEME_A);
3378 putstr (SCHEME_A_ "\n"); 3773 putcharacter (SCHEME_A_ '\n');
3774#if EXPERIMENT
3775 system ("ps v $PPID");
3776#endif
3379 putstr (SCHEME_A_ prompt); 3777 putstr (SCHEME_A_ prompt);
3380 } 3778 }
3381 3779
3382 /* Set up another iteration of REPL */ 3780 /* Set up another iteration of REPL */
3383 SCHEME_V->nesting = 0; 3781 SCHEME_V->nesting = 0;
… …
3418 { 3816 {
3419 SCHEME_V->print_flag = 1; 3817 SCHEME_V->print_flag = 1;
3420 SCHEME_V->args = SCHEME_V->value; 3818 SCHEME_V->args = SCHEME_V->value;
3421 s_goto (OP_P0LIST); 3819 s_goto (OP_P0LIST);
3422 } 3820 }
3423 else 3821
3424 s_return (SCHEME_V->value); 3822 s_return (SCHEME_V->value);
3425 3823
3426 case OP_EVAL: /* main part of evaluation */ 3824 case OP_EVAL: /* main part of evaluation */
3427#if USE_TRACING 3825#if USE_TRACING
3428 if (SCHEME_V->tracing) 3826 if (SCHEME_V->tracing)
3429 { 3827 {
… …
3462 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */ 3860 /* If no macros => s_save(SCHEME_A_ OP_E1ARGS, NIL, cdr(SCHEME_V->code)); */
3463 SCHEME_V->code = x; 3861 SCHEME_V->code = x;
3464 s_goto (OP_EVAL); 3862 s_goto (OP_EVAL);
3465 } 3863 }
3466 } 3864 }
3467 else 3865
3468 s_return (SCHEME_V->code); 3866 s_return (SCHEME_V->code);
3469 3867
3470 case OP_E0ARGS: /* eval arguments */ 3868 case OP_E0ARGS: /* eval arguments */
3471 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */ 3869 if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
3472 { 3870 {
3473 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL); 3871 s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
3474 SCHEME_V->args = cons (SCHEME_V->code, NIL); 3872 SCHEME_V->args = cons (SCHEME_V->code, NIL);
3475 SCHEME_V->code = SCHEME_V->value; 3873 SCHEME_V->code = SCHEME_V->value;
3476 s_goto (OP_APPLY); 3874 s_goto (OP_APPLY);
3477 } 3875 }
3478 else 3876
3479 {
3480 SCHEME_V->code = cdr (SCHEME_V->code); 3877 SCHEME_V->code = cdr (SCHEME_V->code);
3481 s_goto (OP_E1ARGS); 3878 s_goto (OP_E1ARGS);
3482 }
3483 3879
3484 case OP_E1ARGS: /* eval arguments */ 3880 case OP_E1ARGS: /* eval arguments */
3485 args = cons (SCHEME_V->value, args); 3881 args = cons (SCHEME_V->value, args);
3486 3882
3487 if (is_pair (SCHEME_V->code)) /* continue */ 3883 if (is_pair (SCHEME_V->code)) /* continue */
… …
3498 SCHEME_V->args = cdr (args); 3894 SCHEME_V->args = cdr (args);
3499 s_goto (OP_APPLY); 3895 s_goto (OP_APPLY);
3500 } 3896 }
3501 3897
3502#if USE_TRACING 3898#if USE_TRACING
3503
3504 case OP_TRACING: 3899 case OP_TRACING:
3505 { 3900 {
3506 int tr = SCHEME_V->tracing; 3901 int tr = SCHEME_V->tracing;
3507 3902
3508 SCHEME_V->tracing = ivalue_unchecked (car (args)); 3903 SCHEME_V->tracing = ivalue_unchecked (car (args));
3509 s_return (mk_integer (SCHEME_A_ tr)); 3904 s_return (mk_integer (SCHEME_A_ tr));
3510 } 3905 }
3511
3512#endif 3906#endif
3513 3907
3514 case OP_APPLY: /* apply 'code' to 'args' */ 3908 case OP_APPLY: /* apply 'code' to 'args' */
3515#if USE_TRACING 3909#if USE_TRACING
3516 if (SCHEME_V->tracing) 3910 if (SCHEME_V->tracing)
… …
3570 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */ 3964 else if (is_continuation (SCHEME_V->code)) /* CONTINUATION */
3571 { 3965 {
3572 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code)); 3966 ss_set_cont (SCHEME_A_ cont_dump (SCHEME_V->code));
3573 s_return (args != NIL ? car (args) : NIL); 3967 s_return (args != NIL ? car (args) : NIL);
3574 } 3968 }
3575 else 3969
3576 Error_0 ("illegal function"); 3970 Error_0 ("illegal function");
3577 3971
3578 case OP_DOMACRO: /* do macro */ 3972 case OP_DOMACRO: /* do macro */
3579 SCHEME_V->code = SCHEME_V->value; 3973 SCHEME_V->code = SCHEME_V->value;
3580 s_goto (OP_EVAL); 3974 s_goto (OP_EVAL);
3581 3975
… …
3645 else 4039 else
3646 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value); 4040 new_slot_in_env (SCHEME_A_ SCHEME_V->code, SCHEME_V->value);
3647 4041
3648 s_return (SCHEME_V->code); 4042 s_return (SCHEME_V->code);
3649 4043
3650
3651 case OP_DEFP: /* defined? */ 4044 case OP_DEFP: /* defined? */
3652 x = SCHEME_V->envir; 4045 x = SCHEME_V->envir;
3653 4046
3654 if (cdr (args) != NIL) 4047 if (cdr (args) != NIL)
3655 x = cadr (args); 4048 x = cadr (args);
… …
3673 s_return (SCHEME_V->value); 4066 s_return (SCHEME_V->value);
3674 } 4067 }
3675 else 4068 else
3676 Error_1 ("set!: unbound variable:", SCHEME_V->code); 4069 Error_1 ("set!: unbound variable:", SCHEME_V->code);
3677 4070
3678
3679 case OP_BEGIN: /* begin */ 4071 case OP_BEGIN: /* begin */
3680 if (!is_pair (SCHEME_V->code)) 4072 if (!is_pair (SCHEME_V->code))
3681 s_return (SCHEME_V->code); 4073 s_return (SCHEME_V->code);
3682 4074
3683 if (cdr (SCHEME_V->code) != NIL) 4075 if (cdr (SCHEME_V->code) != NIL)
… …
3694 case OP_IF1: /* if */ 4086 case OP_IF1: /* if */
3695 if (is_true (SCHEME_V->value)) 4087 if (is_true (SCHEME_V->value))
3696 SCHEME_V->code = car (SCHEME_V->code); 4088 SCHEME_V->code = car (SCHEME_V->code);
3697 else 4089 else
3698 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */ 4090 SCHEME_V->code = cadr (SCHEME_V->code); /* (if #f 1) ==> () because * car(NIL) = NIL */
4091
3699 s_goto (OP_EVAL); 4092 s_goto (OP_EVAL);
3700 4093
3701 case OP_LET0: /* let */ 4094 case OP_LET0: /* let */
3702 SCHEME_V->args = NIL; 4095 SCHEME_V->args = NIL;
3703 SCHEME_V->value = SCHEME_V->code; 4096 SCHEME_V->value = SCHEME_V->code;
3704 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code); 4097 SCHEME_V->code = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code);
3705 s_goto (OP_LET1); 4098 s_goto (OP_LET1);
3706 4099
3707 case OP_LET1: /* let (calculate parameters) */ 4100 case OP_LET1: /* let (calculate parameters) */
4101 case OP_LET1REC: /* letrec (calculate parameters) */
3708 args = cons (SCHEME_V->value, args); 4102 args = cons (SCHEME_V->value, args);
3709 4103
3710 if (is_pair (SCHEME_V->code)) /* continue */ 4104 if (is_pair (SCHEME_V->code)) /* continue */
3711 { 4105 {
3712 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code))) 4106 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3713 Error_1 ("Bad syntax of binding spec in let :", car (SCHEME_V->code)); 4107 Error_1 ("Bad syntax of binding spec in let/letrec:", car (SCHEME_V->code));
3714 4108
3715 s_save (SCHEME_A_ OP_LET1, args, cdr (SCHEME_V->code)); 4109 s_save (SCHEME_A_ op, args, cdr (SCHEME_V->code));
3716 SCHEME_V->code = cadar (SCHEME_V->code); 4110 SCHEME_V->code = cadar (SCHEME_V->code);
3717 SCHEME_V->args = NIL; 4111 SCHEME_V->args = NIL;
3718 s_goto (OP_EVAL); 4112 s_goto (OP_EVAL);
3719 } 4113 }
3720 else /* end */ 4114
3721 { 4115 /* end */
3722 args = reverse_in_place (SCHEME_A_ NIL, args); 4116 args = reverse_in_place (SCHEME_A_ NIL, args);
3723 SCHEME_V->code = car (args); 4117 SCHEME_V->code = car (args);
3724 SCHEME_V->args = cdr (args); 4118 SCHEME_V->args = cdr (args);
3725 s_goto (OP_LET2); 4119 s_goto (op == OP_LET1 ? OP_LET2 : OP_LET2REC);
3726 }
3727 4120
3728 case OP_LET2: /* let */ 4121 case OP_LET2: /* let */
3729 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4122 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3730 4123
3731 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args; 4124 for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
… …
3735 if (is_symbol (car (SCHEME_V->code))) /* named let */ 4128 if (is_symbol (car (SCHEME_V->code))) /* named let */
3736 { 4129 {
3737 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x)) 4130 for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
3738 { 4131 {
3739 if (!is_pair (x)) 4132 if (!is_pair (x))
3740 Error_1 ("Bad syntax of binding in let :", x); 4133 Error_1 ("Bad syntax of binding in let:", x);
3741 4134
3742 if (!is_list (SCHEME_A_ car (x))) 4135 if (!is_list (SCHEME_A_ car (x)))
3743 Error_1 ("Bad syntax of binding in let :", car (x)); 4136 Error_1 ("Bad syntax of binding in let:", car (x));
3744 4137
3745 args = cons (caar (x), args); 4138 args = cons (caar (x), args);
3746 } 4139 }
3747 4140
3748 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)), 4141 x = mk_closure (SCHEME_A_ cons (reverse_in_place (SCHEME_A_ NIL, args), cddr (SCHEME_V->code)),
… …
3765 SCHEME_V->code = cdr (SCHEME_V->code); 4158 SCHEME_V->code = cdr (SCHEME_V->code);
3766 s_goto (OP_BEGIN); 4159 s_goto (OP_BEGIN);
3767 } 4160 }
3768 4161
3769 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code))) 4162 if (!is_pair (car (SCHEME_V->code)) || !is_pair (caar (SCHEME_V->code)) || !is_pair (cdaar (SCHEME_V->code)))
3770 Error_1 ("Bad syntax of binding spec in let* :", car (SCHEME_V->code)); 4163 Error_1 ("Bad syntax of binding spec in let*:", car (SCHEME_V->code));
3771 4164
3772 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code)); 4165 s_save (SCHEME_A_ OP_LET1AST, cdr (SCHEME_V->code), car (SCHEME_V->code));
3773 SCHEME_V->code = car (cdaar (SCHEME_V->code)); 4166 SCHEME_V->code = car (cdaar (SCHEME_V->code));
3774 s_goto (OP_EVAL); 4167 s_goto (OP_EVAL);
3775 4168
… …
3786 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code); 4179 s_save (SCHEME_A_ OP_LET2AST, args, SCHEME_V->code);
3787 SCHEME_V->code = cadar (SCHEME_V->code); 4180 SCHEME_V->code = cadar (SCHEME_V->code);
3788 SCHEME_V->args = NIL; 4181 SCHEME_V->args = NIL;
3789 s_goto (OP_EVAL); 4182 s_goto (OP_EVAL);
3790 } 4183 }
3791 else /* end */ 4184
4185 /* end */
3792 { 4186
3793 SCHEME_V->code = args; 4187 SCHEME_V->code = args;
3794 SCHEME_V->args = NIL; 4188 SCHEME_V->args = NIL;
3795 s_goto (OP_BEGIN); 4189 s_goto (OP_BEGIN);
3796 }
3797 4190
3798 case OP_LET0REC: /* letrec */ 4191 case OP_LET0REC: /* letrec */
3799 new_frame_in_env (SCHEME_A_ SCHEME_V->envir); 4192 new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
3800 SCHEME_V->args = NIL; 4193 SCHEME_V->args = NIL;
3801 SCHEME_V->value = SCHEME_V->code; 4194 SCHEME_V->value = SCHEME_V->code;
3802 SCHEME_V->code = car (SCHEME_V->code); 4195 SCHEME_V->code = car (SCHEME_V->code);
3803 s_goto (OP_LET1REC); 4196 s_goto (OP_LET1REC);
3804 4197
3805 case OP_LET1REC: /* letrec (calculate parameters) */ 4198 /* OP_LET1REC handled by OP_LET1 */
3806 args = cons (SCHEME_V->value, args);
3807
3808 if (is_pair (SCHEME_V->code)) /* continue */
3809 {
3810 if (!is_pair (car (SCHEME_V->code)) || !is_pair (cdar (SCHEME_V->code)))
3811 Error_1 ("Bad syntax of binding spec in letrec :", car (SCHEME_V->code));
3812
3813 s_save (SCHEME_A_ OP_LET1REC, args, cdr (SCHEME_V->code));
3814 SCHEME_V->code = cadar (SCHEME_V->code);
3815 SCHEME_V->args = NIL;
3816 s_goto (OP_EVAL);
3817 }
3818 else /* end */
3819 {
3820 args = reverse_in_place (SCHEME_A_ NIL, args);
3821 SCHEME_V->code = car (args);
3822 SCHEME_V->args = cdr (args);
3823 s_goto (OP_LET2REC);
3824 }
3825 4199
3826 case OP_LET2REC: /* letrec */ 4200 case OP_LET2REC: /* letrec */
3827 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y)) 4201 for (x = car (SCHEME_V->code), y = args; y != NIL; x = cdr (x), y = cdr (y))
3828 new_slot_in_env (SCHEME_A_ caar (x), car (y)); 4202 new_slot_in_env (SCHEME_A_ caar (x), car (y));
3829 4203
… …
3859 } 4233 }
3860 else 4234 else
3861 { 4235 {
3862 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL) 4236 if ((SCHEME_V->code = cdr (SCHEME_V->code)) == NIL)
3863 s_return (NIL); 4237 s_return (NIL);
3864 else 4238
3865 {
3866 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code); 4239 s_save (SCHEME_A_ OP_COND1, NIL, SCHEME_V->code);
3867 SCHEME_V->code = caar (SCHEME_V->code); 4240 SCHEME_V->code = caar (SCHEME_V->code);
3868 s_goto (OP_EVAL); 4241 s_goto (OP_EVAL);
3869 }
3870 } 4242 }
3871 4243
3872 case OP_DELAY: /* delay */ 4244 case OP_DELAY: /* delay */
3873 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir); 4245 x = mk_closure (SCHEME_A_ cons (NIL, SCHEME_V->code), SCHEME_V->envir);
3874 set_typeflag (x, T_PROMISE); 4246 set_typeflag (x, T_PROMISE);
… …
3885 case OP_AND1: /* and */ 4257 case OP_AND1: /* and */
3886 if (is_false (SCHEME_V->value)) 4258 if (is_false (SCHEME_V->value))
3887 s_return (SCHEME_V->value); 4259 s_return (SCHEME_V->value);
3888 else if (SCHEME_V->code == NIL) 4260 else if (SCHEME_V->code == NIL)
3889 s_return (SCHEME_V->value); 4261 s_return (SCHEME_V->value);
3890 else 4262
3891 {
3892 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code)); 4263 s_save (SCHEME_A_ OP_AND1, NIL, cdr (SCHEME_V->code));
3893 SCHEME_V->code = car (SCHEME_V->code); 4264 SCHEME_V->code = car (SCHEME_V->code);
3894 s_goto (OP_EVAL); 4265 s_goto (OP_EVAL);
3895 }
3896 4266
3897 case OP_OR0: /* or */ 4267 case OP_OR0: /* or */
3898 if (SCHEME_V->code == NIL) 4268 if (SCHEME_V->code == NIL)
3899 s_return (S_F); 4269 s_return (S_F);
3900 4270
… …
3905 case OP_OR1: /* or */ 4275 case OP_OR1: /* or */
3906 if (is_true (SCHEME_V->value)) 4276 if (is_true (SCHEME_V->value))
3907 s_return (SCHEME_V->value); 4277 s_return (SCHEME_V->value);
3908 else if (SCHEME_V->code == NIL) 4278 else if (SCHEME_V->code == NIL)
3909 s_return (SCHEME_V->value); 4279 s_return (SCHEME_V->value);
3910 else 4280
3911 {
3912 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code)); 4281 s_save (SCHEME_A_ OP_OR1, NIL, cdr (SCHEME_V->code));
3913 SCHEME_V->code = car (SCHEME_V->code); 4282 SCHEME_V->code = car (SCHEME_V->code);
3914 s_goto (OP_EVAL); 4283 s_goto (OP_EVAL);
3915 }
3916 4284
3917 case OP_C0STREAM: /* cons-stream */ 4285 case OP_C0STREAM: /* cons-stream */
3918 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code)); 4286 s_save (SCHEME_A_ OP_C1STREAM, NIL, cdr (SCHEME_V->code));
3919 SCHEME_V->code = car (SCHEME_V->code); 4287 SCHEME_V->code = car (SCHEME_V->code);
3920 s_goto (OP_EVAL); 4288 s_goto (OP_EVAL);
… …
3985 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x)); 4353 s_save (SCHEME_A_ OP_CASE2, NIL, cdar (x));
3986 SCHEME_V->code = caar (x); 4354 SCHEME_V->code = caar (x);
3987 s_goto (OP_EVAL); 4355 s_goto (OP_EVAL);
3988 } 4356 }
3989 } 4357 }
3990 else 4358
3991 s_return (NIL); 4359 s_return (NIL);
3992 4360
3993 case OP_CASE2: /* case */ 4361 case OP_CASE2: /* case */
3994 if (is_true (SCHEME_V->value)) 4362 if (is_true (SCHEME_V->value))
3995 s_goto (OP_BEGIN); 4363 s_goto (OP_BEGIN);
3996 else 4364
3997 s_return (NIL); 4365 s_return (NIL);
3998 4366
3999 case OP_PAPPLY: /* apply */ 4367 case OP_PAPPLY: /* apply */
4000 SCHEME_V->code = car (args); 4368 SCHEME_V->code = car (args);
4001 SCHEME_V->args = list_star (SCHEME_A_ cdr (args)); 4369 SCHEME_V->args = list_star (SCHEME_A_ cdr (args));
4002 /*SCHEME_V->args = cadr(args); */ 4370 /*SCHEME_V->args = cadr(args); */
… …
4016 } 4384 }
4017 4385
4018 if (USE_ERROR_CHECKING) abort (); 4386 if (USE_ERROR_CHECKING) abort ();
4019} 4387}
4020 4388
4021static int 4389/* math, cxr */
4390ecb_hot static int
4022opexe_1 (SCHEME_P_ enum scheme_opcodes op) 4391opexe_1 (SCHEME_P_ enum scheme_opcodes op)
4023{ 4392{
4024 pointer args = SCHEME_V->args; 4393 pointer args = SCHEME_V->args;
4025 pointer x = car (args); 4394 pointer x = car (args);
4026 num v; 4395 num v;
4027 4396
4028 switch (op) 4397 switch (op)
4029 { 4398 {
4030#if USE_MATH 4399#if USE_MATH
4031 case OP_INEX2EX: /* inexact->exact */ 4400 case OP_INEX2EX: /* inexact->exact */
4032 {
4033 if (is_integer (x)) 4401 if (!is_integer (x))
4034 s_return (x); 4402 {
4035
4036 RVALUE r = rvalue_unchecked (x); 4403 RVALUE r = rvalue_unchecked (x);
4037 4404
4038 if (r == (RVALUE)(IVALUE)r) 4405 if (r == (RVALUE)(IVALUE)r)
4039 s_return (mk_integer (SCHEME_A_ rvalue_unchecked (x))); 4406 x = mk_integer (SCHEME_A_ rvalue_unchecked (x));
4040 else 4407 else
4041 Error_1 ("inexact->exact: not integral:", x); 4408 Error_1 ("inexact->exact: not integral:", x);
4042 } 4409 }
4043 4410
4411 s_return (x);
4412
4413 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4414 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4415 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4416 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4417
4418 case OP_SQRT: s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4044 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x)))); 4419 case OP_EXP: s_return (mk_real (SCHEME_A_ exp (rvalue (x))));
4045 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x)))); 4420 case OP_LOG: s_return (mk_real (SCHEME_A_ log (rvalue (x))
4421 / (cadr (args) == NIL ? 1 : log (rvalue (cadr (args))))));
4046 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x)))); 4422 case OP_SIN: s_return (mk_real (SCHEME_A_ sin (rvalue (x))));
4047 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x)))); 4423 case OP_COS: s_return (mk_real (SCHEME_A_ cos (rvalue (x))));
4048 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x)))); 4424 case OP_TAN: s_return (mk_real (SCHEME_A_ tan (rvalue (x))));
4049 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x)))); 4425 case OP_ASIN: s_return (mk_real (SCHEME_A_ asin (rvalue (x))));
4050 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x)))); 4426 case OP_ACOS: s_return (mk_real (SCHEME_A_ acos (rvalue (x))));
4051 4427
4052 case OP_ATAN: 4428 case OP_ATAN:
4429 s_return (mk_real (SCHEME_A_
4053 if (cdr (args) == NIL) 4430 cdr (args) == NIL
4054 s_return (mk_real (SCHEME_A_ atan (rvalue (x)))); 4431 ? atan (rvalue (x))
4055 else 4432 : atan2 (rvalue (x), rvalue (cadr (args)))));
4056 {
4057 pointer y = cadr (args);
4058 s_return (mk_real (SCHEME_A_ atan2 (rvalue (x), rvalue (y))));
4059 }
4060
4061 case OP_SQRT:
4062 s_return (mk_real (SCHEME_A_ sqrt (rvalue (x))));
4063 4433
4064 case OP_EXPT: 4434 case OP_EXPT:
4065 { 4435 {
4066 RVALUE result; 4436 RVALUE result;
4067 int real_result = 1; 4437 int real_result = 1;
… …
4090 if (real_result) 4460 if (real_result)
4091 s_return (mk_real (SCHEME_A_ result)); 4461 s_return (mk_real (SCHEME_A_ result));
4092 else 4462 else
4093 s_return (mk_integer (SCHEME_A_ result)); 4463 s_return (mk_integer (SCHEME_A_ result));
4094 } 4464 }
4095
4096 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4097 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4098
4099 case OP_TRUNCATE:
4100 {
4101 RVALUE n = rvalue (x);
4102 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4103 }
4104
4105 case OP_ROUND:
4106 if (is_integer (x))
4107 s_return (x);
4108
4109 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x))));
4110#endif 4465#endif
4111 4466
4112 case OP_ADD: /* + */ 4467 case OP_ADD: /* + */
4113 v = num_zero; 4468 v = num_zero;
4114 4469
… …
4416 memcpy (pos, strvalue (car (x)), strlength (car (x))); 4771 memcpy (pos, strvalue (car (x)), strlength (car (x)));
4417 4772
4418 s_return (newstr); 4773 s_return (newstr);
4419 } 4774 }
4420 4775
4421 case OP_SUBSTR: /* substring */ 4776 case OP_STRING_COPY: /* substring/string-copy */
4422 { 4777 {
4423 char *str = strvalue (x); 4778 char *str = strvalue (x);
4424 int index0 = ivalue_unchecked (cadr (args)); 4779 int index0 = cadr (args) == NIL ? 0 : ivalue_unchecked (cadr (args));
4425 int index1; 4780 int index1;
4426 int len; 4781 int len;
4427 4782
4428 if (index0 > strlength (x)) 4783 if (index0 > strlength (x))
4429 Error_1 ("substring: start out of bounds:", cadr (args)); 4784 Error_1 ("string->copy: start out of bounds:", cadr (args));
4430 4785
4431 if (cddr (args) != NIL) 4786 if (cddr (args) != NIL)
4432 { 4787 {
4433 index1 = ivalue_unchecked (caddr (args)); 4788 index1 = ivalue_unchecked (caddr (args));
4434 4789
4435 if (index1 > strlength (x) || index1 < index0) 4790 if (index1 > strlength (x) || index1 < index0)
4436 Error_1 ("substring: end out of bounds:", caddr (args)); 4791 Error_1 ("string->copy: end out of bounds:", caddr (args));
4437 } 4792 }
4438 else 4793 else
4439 index1 = strlength (x); 4794 index1 = strlength (x);
4440 4795
4441 len = index1 - index0; 4796 len = index1 - index0;
4442 x = mk_empty_string (SCHEME_A_ len, ' '); 4797 x = mk_counted_string (SCHEME_A_ str + index0, len);
4443 memcpy (strvalue (x), str + index0, len);
4444 strvalue (x)[len] = 0;
4445 4798
4446 s_return (x); 4799 s_return (x);
4447 } 4800 }
4448 4801
4449 case OP_VECTOR: /* vector */ 4802 case OP_VECTOR: /* vector */
… …
4523 } 4876 }
4524 4877
4525 if (USE_ERROR_CHECKING) abort (); 4878 if (USE_ERROR_CHECKING) abort ();
4526} 4879}
4527 4880
4528static int 4881/* relational ops */
4882ecb_hot static int
4529opexe_2 (SCHEME_P_ enum scheme_opcodes op) 4883opexe_2 (SCHEME_P_ enum scheme_opcodes op)
4530{ 4884{
4531 pointer x = SCHEME_V->args; 4885 pointer x = SCHEME_V->args;
4532 4886
4533 for (;;) 4887 for (;;)
… …
4554 } 4908 }
4555 4909
4556 s_return (S_T); 4910 s_return (S_T);
4557} 4911}
4558 4912
4559static int 4913/* predicates */
4914ecb_hot static int
4560opexe_3 (SCHEME_P_ enum scheme_opcodes op) 4915opexe_3 (SCHEME_P_ enum scheme_opcodes op)
4561{ 4916{
4562 pointer args = SCHEME_V->args; 4917 pointer args = SCHEME_V->args;
4563 pointer a = car (args); 4918 pointer a = car (args);
4564 pointer d = cdr (args); 4919 pointer d = cdr (args);
… …
4611 } 4966 }
4612 4967
4613 s_retbool (r); 4968 s_retbool (r);
4614} 4969}
4615 4970
4616static int 4971/* promises, list ops, ports */
4972ecb_hot static int
4617opexe_4 (SCHEME_P_ enum scheme_opcodes op) 4973opexe_4 (SCHEME_P_ enum scheme_opcodes op)
4618{ 4974{
4619 pointer args = SCHEME_V->args; 4975 pointer args = SCHEME_V->args;
4620 pointer a = car (args); 4976 pointer a = car (args);
4621 pointer x, y; 4977 pointer x, y;
… …
4638 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4994 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4639 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value); 4995 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4640 s_return (SCHEME_V->value); 4996 s_return (SCHEME_V->value);
4641 4997
4642#if USE_PORTS 4998#if USE_PORTS
4999
5000 case OP_EOF_OBJECT: /* eof-object */
5001 s_return (S_EOF);
4643 5002
4644 case OP_WRITE: /* write */ 5003 case OP_WRITE: /* write */
4645 case OP_DISPLAY: /* display */ 5004 case OP_DISPLAY: /* display */
4646 case OP_WRITE_CHAR: /* write-char */ 5005 case OP_WRITE_CHAR: /* write-char */
4647 if (is_pair (cdr (SCHEME_V->args))) 5006 if (is_pair (cdr (SCHEME_V->args)))
… …
4661 else 5020 else
4662 SCHEME_V->print_flag = 0; 5021 SCHEME_V->print_flag = 0;
4663 5022
4664 s_goto (OP_P0LIST); 5023 s_goto (OP_P0LIST);
4665 5024
5025 //TODO: move to scheme
4666 case OP_NEWLINE: /* newline */ 5026 case OP_NEWLINE: /* newline */
4667 if (is_pair (args)) 5027 if (is_pair (args))
4668 { 5028 {
4669 if (a != SCHEME_V->outport) 5029 if (a != SCHEME_V->outport)
4670 { 5030 {
… …
4672 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL); 5032 s_save (SCHEME_A_ OP_SET_OUTPORT, x, NIL);
4673 SCHEME_V->outport = a; 5033 SCHEME_V->outport = a;
4674 } 5034 }
4675 } 5035 }
4676 5036
4677 putstr (SCHEME_A_ "\n"); 5037 putcharacter (SCHEME_A_ '\n');
4678 s_return (S_T); 5038 s_return (S_T);
4679#endif 5039#endif
4680 5040
4681 case OP_ERR0: /* error */ 5041 case OP_ERR0: /* error */
4682 SCHEME_V->retcode = -1; 5042 SCHEME_V->retcode = -1;
… …
4691 putstr (SCHEME_A_ strvalue (car (args))); 5051 putstr (SCHEME_A_ strvalue (car (args)));
4692 SCHEME_V->args = cdr (args); 5052 SCHEME_V->args = cdr (args);
4693 s_goto (OP_ERR1); 5053 s_goto (OP_ERR1);
4694 5054
4695 case OP_ERR1: /* error */ 5055 case OP_ERR1: /* error */
4696 putstr (SCHEME_A_ " "); 5056 putcharacter (SCHEME_A_ ' ');
4697 5057
4698 if (args != NIL) 5058 if (args != NIL)
4699 { 5059 {
4700 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL); 5060 s_save (SCHEME_A_ OP_ERR1, cdr (args), NIL);
4701 SCHEME_V->args = a; 5061 SCHEME_V->args = a;
4702 SCHEME_V->print_flag = 1; 5062 SCHEME_V->print_flag = 1;
4703 s_goto (OP_P0LIST); 5063 s_goto (OP_P0LIST);
4704 } 5064 }
4705 else 5065 else
4706 { 5066 {
4707 putstr (SCHEME_A_ "\n"); 5067 putcharacter (SCHEME_A_ '\n');
4708 5068
4709 if (SCHEME_V->interactive_repl) 5069 if (SCHEME_V->interactive_repl)
4710 s_goto (OP_T0LVL); 5070 s_goto (OP_T0LVL);
4711 else 5071 else
4712 return -1; 5072 return -1;
… …
4920 } 5280 }
4921 5281
4922 if (USE_ERROR_CHECKING) abort (); 5282 if (USE_ERROR_CHECKING) abort ();
4923} 5283}
4924 5284
4925static int 5285/* reading */
5286ecb_cold static int
4926opexe_5 (SCHEME_P_ enum scheme_opcodes op) 5287opexe_5 (SCHEME_P_ enum scheme_opcodes op)
4927{ 5288{
4928 pointer args = SCHEME_V->args; 5289 pointer args = SCHEME_V->args;
4929 pointer x; 5290 pointer x;
4930 5291
… …
5009 case OP_RDSEXPR: 5370 case OP_RDSEXPR:
5010 switch (SCHEME_V->tok) 5371 switch (SCHEME_V->tok)
5011 { 5372 {
5012 case TOK_EOF: 5373 case TOK_EOF:
5013 s_return (S_EOF); 5374 s_return (S_EOF);
5014 /* NOTREACHED */
5015 5375
5016 case TOK_VEC: 5376 case TOK_VEC:
5017 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL); 5377 s_save (SCHEME_A_ OP_RDVEC, NIL, NIL);
5018 /* fall through */ 5378 /* fall through */
5019 5379
… …
5022 5382
5023 if (SCHEME_V->tok == TOK_RPAREN) 5383 if (SCHEME_V->tok == TOK_RPAREN)
5024 s_return (NIL); 5384 s_return (NIL);
5025 else if (SCHEME_V->tok == TOK_DOT) 5385 else if (SCHEME_V->tok == TOK_DOT)
5026 Error_0 ("syntax error: illegal dot expression"); 5386 Error_0 ("syntax error: illegal dot expression");
5027 else 5387
5028 {
5029 SCHEME_V->nesting_stack[SCHEME_V->file_i]++; 5388 SCHEME_V->nesting_stack[SCHEME_V->file_i]++;
5030 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL); 5389 s_save (SCHEME_A_ OP_RDLIST, NIL, NIL);
5031 s_goto (OP_RDSEXPR); 5390 s_goto (OP_RDSEXPR);
5032 }
5033 5391
5034 case TOK_QUOTE: 5392 case TOK_QUOTE:
5035 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL); 5393 s_save (SCHEME_A_ OP_RDQUOTE, NIL, NIL);
5036 SCHEME_V->tok = token (SCHEME_A); 5394 SCHEME_V->tok = token (SCHEME_A);
5037 s_goto (OP_RDSEXPR); 5395 s_goto (OP_RDSEXPR);
… …
5043 { 5401 {
5044 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL); 5402 s_save (SCHEME_A_ OP_RDQQUOTEVEC, NIL, NIL);
5045 SCHEME_V->tok = TOK_LPAREN; 5403 SCHEME_V->tok = TOK_LPAREN;
5046 s_goto (OP_RDSEXPR); 5404 s_goto (OP_RDSEXPR);
5047 } 5405 }
5048 else 5406
5049 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL); 5407 s_save (SCHEME_A_ OP_RDQQUOTE, NIL, NIL);
5050
5051 s_goto (OP_RDSEXPR); 5408 s_goto (OP_RDSEXPR);
5052 5409
5053 case TOK_COMMA: 5410 case TOK_COMMA:
5054 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL); 5411 s_save (SCHEME_A_ OP_RDUNQUOTE, NIL, NIL);
5055 SCHEME_V->tok = token (SCHEME_A); 5412 SCHEME_V->tok = token (SCHEME_A);
… …
5066 case TOK_DOTATOM: 5423 case TOK_DOTATOM:
5067 SCHEME_V->strbuff[0] = '.'; 5424 SCHEME_V->strbuff[0] = '.';
5068 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS))); 5425 s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
5069 5426
5070 case TOK_STRATOM: 5427 case TOK_STRATOM:
5428 //TODO: haven't checked whether the garbage collector could interfere and free x
5429 gc (SCHEME_A_ NIL, NIL); //TODO: superheavyhanded
5071 x = readstrexp (SCHEME_A_ '|'); 5430 x = readstrexp (SCHEME_A_ '|');
5072 //TODO: haven't checked whether the garbage collector could interfere
5073 s_return (mk_atom (SCHEME_A_ strvalue (x))); 5431 s_return (mk_atom (SCHEME_A_ strvalue (x)));
5074 5432
5075 case TOK_DQUOTE: 5433 case TOK_DQUOTE:
5076 x = readstrexp (SCHEME_A_ '"'); 5434 x = readstrexp (SCHEME_A_ '"');
5077 5435
… …
5085 { 5443 {
5086 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1); 5444 pointer f = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->SHARP_HOOK, 1);
5087 5445
5088 if (f == NIL) 5446 if (f == NIL)
5089 Error_0 ("undefined sharp expression"); 5447 Error_0 ("undefined sharp expression");
5090 else 5448
5091 {
5092 SCHEME_V->code = cons (slot_value_in_env (f), NIL); 5449 SCHEME_V->code = cons (slot_value_in_env (f), NIL);
5093 s_goto (OP_EVAL); 5450 s_goto (OP_EVAL);
5094 }
5095 } 5451 }
5096 5452
5097 case TOK_SHARP_CONST: 5453 case TOK_SHARP_CONST:
5098 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL) 5454 if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
5099 Error_0 ("undefined sharp expression"); 5455 Error_0 ("undefined sharp expression");
5100 else 5456
5101 s_return (x); 5457 s_return (x);
5102 5458
5103 default: 5459 default:
5104 Error_0 ("syntax error: illegal token"); 5460 Error_0 ("syntax error: illegal token");
5105 } 5461 }
5106 5462
… …
5199 pointer b = cdr (args); 5555 pointer b = cdr (args);
5200 int ok_abbr = ok_abbrev (b); 5556 int ok_abbr = ok_abbrev (b);
5201 SCHEME_V->args = car (b); 5557 SCHEME_V->args = car (b);
5202 5558
5203 if (a == SCHEME_V->QUOTE && ok_abbr) 5559 if (a == SCHEME_V->QUOTE && ok_abbr)
5204 putstr (SCHEME_A_ "'"); 5560 putcharacter (SCHEME_A_ '\'');
5205 else if (a == SCHEME_V->QQUOTE && ok_abbr) 5561 else if (a == SCHEME_V->QQUOTE && ok_abbr)
5206 putstr (SCHEME_A_ "`"); 5562 putcharacter (SCHEME_A_ '`');
5207 else if (a == SCHEME_V->UNQUOTE && ok_abbr) 5563 else if (a == SCHEME_V->UNQUOTE && ok_abbr)
5208 putstr (SCHEME_A_ ","); 5564 putcharacter (SCHEME_A_ ',');
5209 else if (a == SCHEME_V->UNQUOTESP && ok_abbr) 5565 else if (a == SCHEME_V->UNQUOTESP && ok_abbr)
5210 putstr (SCHEME_A_ ",@"); 5566 putstr (SCHEME_A_ ",@");
5211 else 5567 else
5212 { 5568 {
5213 putstr (SCHEME_A_ "("); 5569 putcharacter (SCHEME_A_ '(');
5214 s_save (SCHEME_A_ OP_P1LIST, b, NIL); 5570 s_save (SCHEME_A_ OP_P1LIST, b, NIL);
5215 SCHEME_V->args = a; 5571 SCHEME_V->args = a;
5216 } 5572 }
5217 5573
5218 s_goto (OP_P0LIST); 5574 s_goto (OP_P0LIST);
… …
5220 5576
5221 case OP_P1LIST: 5577 case OP_P1LIST:
5222 if (is_pair (args)) 5578 if (is_pair (args))
5223 { 5579 {
5224 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL); 5580 s_save (SCHEME_A_ OP_P1LIST, cdr (args), NIL);
5225 putstr (SCHEME_A_ " "); 5581 putcharacter (SCHEME_A_ ' ');
5226 SCHEME_V->args = car (args); 5582 SCHEME_V->args = car (args);
5227 s_goto (OP_P0LIST); 5583 s_goto (OP_P0LIST);
5228 } 5584 }
5229 else if (is_vector (args)) 5585 else if (is_vector (args))
5230 { 5586 {
… …
5238 { 5594 {
5239 putstr (SCHEME_A_ " . "); 5595 putstr (SCHEME_A_ " . ");
5240 printatom (SCHEME_A_ args, SCHEME_V->print_flag); 5596 printatom (SCHEME_A_ args, SCHEME_V->print_flag);
5241 } 5597 }
5242 5598
5243 putstr (SCHEME_A_ ")"); 5599 putcharacter (SCHEME_A_ ')');
5244 s_return (S_T); 5600 s_return (S_T);
5245 } 5601 }
5246 5602
5247 case OP_PVECFROM: 5603 case OP_PVECFROM:
5248 { 5604 {
5249 int i = ivalue_unchecked (cdr (args)); 5605 IVALUE i = ivalue_unchecked (cdr (args));
5250 pointer vec = car (args); 5606 pointer vec = car (args);
5251 int len = veclength (vec); 5607 uint32_t len = veclength (vec);
5252 5608
5253 if (i == len) 5609 if (i == len)
5254 { 5610 {
5255 putstr (SCHEME_A_ ")"); 5611 putcharacter (SCHEME_A_ ')');
5256 s_return (S_T); 5612 s_return (S_T);
5257 } 5613 }
5258 else 5614 else
5259 { 5615 {
5260 pointer elem = vector_get (vec, i); 5616 pointer elem = vector_get (vec, i);
5261 5617
5262 ivalue_unchecked (cdr (args)) = i + 1; 5618 set_cdr (args, mk_integer (SCHEME_A_ i + 1));
5263 s_save (SCHEME_A_ OP_PVECFROM, args, NIL); 5619 s_save (SCHEME_A_ OP_PVECFROM, args, NIL);
5264 SCHEME_V->args = elem; 5620 SCHEME_V->args = elem;
5265 5621
5266 if (i > 0) 5622 if (i > 0)
5267 putstr (SCHEME_A_ " "); 5623 putcharacter (SCHEME_A_ ' ');
5268 5624
5269 s_goto (OP_P0LIST); 5625 s_goto (OP_P0LIST);
5270 } 5626 }
5271 } 5627 }
5272 } 5628 }
5273 5629
5274 if (USE_ERROR_CHECKING) abort (); 5630 if (USE_ERROR_CHECKING) abort ();
5275} 5631}
5276 5632
5277static int 5633/* list ops */
5634ecb_hot static int
5278opexe_6 (SCHEME_P_ enum scheme_opcodes op) 5635opexe_6 (SCHEME_P_ enum scheme_opcodes op)
5279{ 5636{
5280 pointer args = SCHEME_V->args; 5637 pointer args = SCHEME_V->args;
5281 pointer a = car (args); 5638 pointer a = car (args);
5282 pointer x, y; 5639 pointer x, y;
… …
5305 break; 5662 break;
5306 } 5663 }
5307 5664
5308 if (is_pair (y)) 5665 if (is_pair (y))
5309 s_return (car (y)); 5666 s_return (car (y));
5310 else 5667
5311 s_return (S_F); 5668 s_return (S_F);
5312
5313 5669
5314 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */ 5670 case OP_GET_CLOSURE: /* get-closure-code *//* a.k */
5315 SCHEME_V->args = a; 5671 SCHEME_V->args = a;
5316 5672
5317 if (SCHEME_V->args == NIL) 5673 if (SCHEME_V->args == NIL)
5318 s_return (S_F); 5674 s_return (S_F);
5319 else if (is_closure (SCHEME_V->args)) 5675 else if (is_closure (SCHEME_V->args) || is_macro (SCHEME_V->args))
5320 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value))); 5676 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5321 else if (is_macro (SCHEME_V->args)) 5677
5322 s_return (cons (SCHEME_V->LAMBDA, closure_code (SCHEME_V->value)));
5323 else
5324 s_return (S_F); 5678 s_return (S_F);
5325 5679
5326 case OP_CLOSUREP: /* closure? */ 5680 case OP_CLOSUREP: /* closure? */
5327 /* 5681 /*
5328 * Note, macro object is also a closure. 5682 * Note, macro object is also a closure.
5329 * Therefore, (closure? <#MACRO>) ==> #t 5683 * Therefore, (closure? <#MACRO>) ==> #t
… …
5340 5694
5341/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ 5695/* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */
5342typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); 5696typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes);
5343 5697
5344typedef int (*test_predicate)(pointer); 5698typedef int (*test_predicate)(pointer);
5345static int 5699
5700ecb_hot static int
5346tst_any (pointer p) 5701tst_any (pointer p)
5347{ 5702{
5348 return 1; 5703 return 1;
5349} 5704}
5350 5705
5351static int 5706ecb_hot static int
5352tst_inonneg (pointer p) 5707tst_inonneg (pointer p)
5353{ 5708{
5354 return is_integer (p) && ivalue_unchecked (p) >= 0; 5709 return is_integer (p) && ivalue_unchecked (p) >= 0;
5355} 5710}
5356 5711
5357static int 5712ecb_hot static int
5358tst_is_list (SCHEME_P_ pointer p) 5713tst_is_list (SCHEME_P_ pointer p)
5359{ 5714{
5360 return p == NIL || is_pair (p); 5715 return p == NIL || is_pair (p);
5361} 5716}
5362 5717
… …
5405#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00" 5760#define OP_DEF(func,name,minarity,maxarity,argtest,op) name "\x00"
5406#include "opdefines.h" 5761#include "opdefines.h"
5407#undef OP_DEF 5762#undef OP_DEF
5408; 5763;
5409 5764
5410static const char * 5765ecb_cold static const char *
5411opname (int idx) 5766opname (int idx)
5412{ 5767{
5413 const char *name = opnames; 5768 const char *name = opnames;
5414 5769
5415 /* should do this at compile time, but would require external program, right? */ 5770 /* should do this at compile time, but would require external program, right? */
… …
5417 name += strlen (name) + 1; 5772 name += strlen (name) + 1;
5418 5773
5419 return *name ? name : "ILLEGAL"; 5774 return *name ? name : "ILLEGAL";
5420} 5775}
5421 5776
5422static const char * 5777ecb_cold static const char *
5423procname (pointer x) 5778procname (pointer x)
5424{ 5779{
5425 return opname (procnum (x)); 5780 return opname (procnum (x));
5426} 5781}
5427 5782
… …
5447#undef OP_DEF 5802#undef OP_DEF
5448 {0} 5803 {0}
5449}; 5804};
5450 5805
5451/* kernel of this interpreter */ 5806/* kernel of this interpreter */
5452static void ecb_hot 5807ecb_hot static void
5453Eval_Cycle (SCHEME_P_ enum scheme_opcodes op) 5808Eval_Cycle (SCHEME_P_ enum scheme_opcodes op)
5454{ 5809{
5455 SCHEME_V->op = op; 5810 SCHEME_V->op = op;
5456 5811
5457 for (;;) 5812 for (;;)
… …
5548 } 5903 }
5549} 5904}
5550 5905
5551/* ========== Initialization of internal keywords ========== */ 5906/* ========== Initialization of internal keywords ========== */
5552 5907
5553static void 5908ecb_cold static void
5554assign_syntax (SCHEME_P_ const char *name) 5909assign_syntax (SCHEME_P_ const char *name)
5555{ 5910{
5556 pointer x = oblist_add_by_name (SCHEME_A_ name); 5911 pointer x = oblist_add_by_name (SCHEME_A_ name);
5557 set_typeflag (x, typeflag (x) | T_SYNTAX); 5912 set_typeflag (x, typeflag (x) | T_SYNTAX);
5558} 5913}
5559 5914
5560static void 5915ecb_cold static void
5561assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name) 5916assign_proc (SCHEME_P_ enum scheme_opcodes op, const char *name)
5562{ 5917{
5563 pointer x = mk_symbol (SCHEME_A_ name); 5918 pointer x = mk_symbol (SCHEME_A_ name);
5564 pointer y = mk_proc (SCHEME_A_ op); 5919 pointer y = mk_proc (SCHEME_A_ op);
5565 new_slot_in_env (SCHEME_A_ x, y); 5920 new_slot_in_env (SCHEME_A_ x, y);
… …
5568static pointer 5923static pointer
5569mk_proc (SCHEME_P_ enum scheme_opcodes op) 5924mk_proc (SCHEME_P_ enum scheme_opcodes op)
5570{ 5925{
5571 pointer y = get_cell (SCHEME_A_ NIL, NIL); 5926 pointer y = get_cell (SCHEME_A_ NIL, NIL);
5572 set_typeflag (y, (T_PROC | T_ATOM)); 5927 set_typeflag (y, (T_PROC | T_ATOM));
5573 ivalue_unchecked (y) = op; 5928 set_ivalue (y, op);
5574 return y; 5929 return y;
5575} 5930}
5576 5931
5577/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ 5932/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
5578static int 5933ecb_hot static int
5579syntaxnum (pointer p) 5934syntaxnum (pointer p)
5580{ 5935{
5581 const char *s = strvalue (p); 5936 const char *s = strvalue (p);
5582 5937
5583 switch (strlength (p)) 5938 switch (strlength (p))
… …
5662 6017
5663ecb_cold int 6018ecb_cold int
5664scheme_init (SCHEME_P) 6019scheme_init (SCHEME_P)
5665{ 6020{
5666 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 6021 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5667 pointer x;
5668 6022
5669 /* this memset is not strictly correct, as we assume (intcache) 6023 /* this memset is not strictly correct, as we assume (intcache)
5670 * that memset 0 will also set pointers to 0, but memset does 6024 * that memset 0 will also set pointers to 0, but memset does
5671 * of course not guarantee that. screw such systems. 6025 * of course not guarantee that. screw such systems.
5672 */ 6026 */
… …
5700#endif 6054#endif
5701 } 6055 }
5702 6056
5703 SCHEME_V->gc_verbose = 0; 6057 SCHEME_V->gc_verbose = 0;
5704 dump_stack_initialize (SCHEME_A); 6058 dump_stack_initialize (SCHEME_A);
5705 SCHEME_V->code = NIL; 6059 SCHEME_V->code = NIL;
5706 SCHEME_V->args = NIL; 6060 SCHEME_V->args = NIL;
5707 SCHEME_V->envir = NIL; 6061 SCHEME_V->envir = NIL;
6062 SCHEME_V->value = NIL;
5708 SCHEME_V->tracing = 0; 6063 SCHEME_V->tracing = 0;
5709 6064
5710 /* init NIL */ 6065 /* init NIL */
5711 set_typeflag (NIL, T_ATOM | T_MARK); 6066 set_typeflag (NIL, T_SPECIAL | T_ATOM);
5712 set_car (NIL, NIL); 6067 set_car (NIL, NIL);
5713 set_cdr (NIL, NIL); 6068 set_cdr (NIL, NIL);
5714 /* init T */ 6069 /* init T */
5715 set_typeflag (S_T, T_ATOM | T_MARK); 6070 set_typeflag (S_T, T_SPECIAL | T_ATOM);
5716 set_car (S_T, S_T); 6071 set_car (S_T, S_T);
5717 set_cdr (S_T, S_T); 6072 set_cdr (S_T, S_T);
5718 /* init F */ 6073 /* init F */
5719 set_typeflag (S_F, T_ATOM | T_MARK); 6074 set_typeflag (S_F, T_SPECIAL | T_ATOM);
5720 set_car (S_F, S_F); 6075 set_car (S_F, S_F);
5721 set_cdr (S_F, S_F); 6076 set_cdr (S_F, S_F);
5722 /* init EOF_OBJ */ 6077 /* init EOF_OBJ */
5723 set_typeflag (S_EOF, T_ATOM | T_MARK); 6078 set_typeflag (S_EOF, T_SPECIAL | T_ATOM);
5724 set_car (S_EOF, S_EOF); 6079 set_car (S_EOF, S_EOF);
5725 set_cdr (S_EOF, S_EOF); 6080 set_cdr (S_EOF, S_EOF);
5726 /* init sink */ 6081 /* init sink */
5727 set_typeflag (S_SINK, T_PAIR | T_MARK); 6082 set_typeflag (S_SINK, T_PAIR);
5728 set_car (S_SINK, NIL); 6083 set_car (S_SINK, NIL);
5729 6084
5730 /* init c_nest */ 6085 /* init c_nest */
5731 SCHEME_V->c_nest = NIL; 6086 SCHEME_V->c_nest = NIL;
5732 6087
5733 SCHEME_V->oblist = oblist_initial_value (SCHEME_A); 6088 SCHEME_V->oblist = oblist_initial_value (SCHEME_A);
5734 /* init global_env */ 6089 /* init global_env */
5735 new_frame_in_env (SCHEME_A_ NIL); 6090 new_frame_in_env (SCHEME_A_ NIL);
5736 SCHEME_V->global_env = SCHEME_V->envir; 6091 SCHEME_V->global_env = SCHEME_V->envir;
5737 /* init else */ 6092 /* init else */
5738 x = mk_symbol (SCHEME_A_ "else"); 6093 new_slot_in_env (SCHEME_A_ mk_symbol (SCHEME_A_ "else"), S_T);
5739 new_slot_in_env (SCHEME_A_ x, S_T);
5740 6094
5741 { 6095 {
5742 static const char *syntax_names[] = { 6096 static const char *syntax_names[] = {
5743 "lambda", "quote", "define", "if", "begin", "set!", 6097 "lambda", "quote", "define", "if", "begin", "set!",
5744 "let", "let*", "letrec", "cond", "delay", "and", 6098 "let", "let*", "letrec", "cond", "delay", "and",
… …
5768 6122
5769 return !SCHEME_V->no_memory; 6123 return !SCHEME_V->no_memory;
5770} 6124}
5771 6125
5772#if USE_PORTS 6126#if USE_PORTS
5773void 6127ecb_cold void
5774scheme_set_input_port_file (SCHEME_P_ int fin) 6128scheme_set_input_port_file (SCHEME_P_ int fin)
5775{ 6129{
5776 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input); 6130 SCHEME_V->inport = port_from_file (SCHEME_A_ fin, port_input);
5777} 6131}
5778 6132
5779void 6133ecb_cold void
5780scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end) 6134scheme_set_input_port_string (SCHEME_P_ char *start, char *past_the_end)
5781{ 6135{
5782 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input); 6136 SCHEME_V->inport = port_from_string (SCHEME_A_ start, past_the_end, port_input);
5783} 6137}
5784 6138
5785void 6139ecb_cold void
5786scheme_set_output_port_file (SCHEME_P_ int fout) 6140scheme_set_output_port_file (SCHEME_P_ int fout)
5787{ 6141{
5788 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output); 6142 SCHEME_V->outport = port_from_file (SCHEME_A_ fout, port_output);
5789} 6143}
5790 6144
5791void 6145ecb_cold void
5792scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end) 6146scheme_set_output_port_string (SCHEME_P_ char *start, char *past_the_end)
5793{ 6147{
5794 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output); 6148 SCHEME_V->outport = port_from_string (SCHEME_A_ start, past_the_end, port_output);
5795} 6149}
5796#endif 6150#endif
5797 6151
5798void 6152ecb_cold void
5799scheme_set_external_data (SCHEME_P_ void *p) 6153scheme_set_external_data (SCHEME_P_ void *p)
5800{ 6154{
5801 SCHEME_V->ext_data = p; 6155 SCHEME_V->ext_data = p;
5802} 6156}
5803 6157
… …
5835 SCHEME_V->loadport = NIL; 6189 SCHEME_V->loadport = NIL;
5836 SCHEME_V->gc_verbose = 0; 6190 SCHEME_V->gc_verbose = 0;
5837 gc (SCHEME_A_ NIL, NIL); 6191 gc (SCHEME_A_ NIL, NIL);
5838 6192
5839 for (i = 0; i <= SCHEME_V->last_cell_seg; i++) 6193 for (i = 0; i <= SCHEME_V->last_cell_seg; i++)
5840 free (SCHEME_V->alloc_seg[i]); 6194 free (SCHEME_V->cell_seg[i]);
5841 6195
5842#if SHOW_ERROR_LINE 6196#if SHOW_ERROR_LINE
5843 for (i = 0; i <= SCHEME_V->file_i; i++) 6197 for (i = 0; i <= SCHEME_V->file_i; i++)
5844 {
5845 if (SCHEME_V->load_stack[i].kind & port_file) 6198 if (SCHEME_V->load_stack[i].kind & port_file)
5846 { 6199 {
5847 fname = SCHEME_V->load_stack[i].rep.stdio.filename; 6200 fname = SCHEME_V->load_stack[i].rep.stdio.filename;
5848 6201
5849 if (fname) 6202 if (fname)
5850 free (fname); 6203 free (fname);
5851 } 6204 }
5852 }
5853#endif 6205#endif
5854} 6206}
5855 6207
5856void 6208ecb_cold void
5857scheme_load_file (SCHEME_P_ int fin) 6209scheme_load_file (SCHEME_P_ int fin)
5858{ 6210{
5859 scheme_load_named_file (SCHEME_A_ fin, 0); 6211 scheme_load_named_file (SCHEME_A_ fin, 0);
5860} 6212}
5861 6213
5862void 6214ecb_cold void
5863scheme_load_named_file (SCHEME_P_ int fin, const char *filename) 6215scheme_load_named_file (SCHEME_P_ int fin, const char *filename)
5864{ 6216{
5865 dump_stack_reset (SCHEME_A); 6217 dump_stack_reset (SCHEME_A);
5866 SCHEME_V->envir = SCHEME_V->global_env; 6218 SCHEME_V->envir = SCHEME_V->global_env;
5867 SCHEME_V->file_i = 0; 6219 SCHEME_V->file_i = 0;
5868 SCHEME_V->load_stack[0].unget = -1; 6220 SCHEME_V->load_stack[0].unget = -1;
5869 SCHEME_V->load_stack[0].kind = port_input | port_file; 6221 SCHEME_V->load_stack[0].kind = port_input | port_file;
5870 SCHEME_V->load_stack[0].rep.stdio.file = fin; 6222 SCHEME_V->load_stack[0].rep.stdio.file = fin;
5871#if USE_PORTS
5872 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 6223 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5873#endif
5874 SCHEME_V->retcode = 0; 6224 SCHEME_V->retcode = 0;
5875 6225
5876#if USE_PORTS
5877 if (fin == STDIN_FILENO) 6226 if (fin == STDIN_FILENO)
5878 SCHEME_V->interactive_repl = 1; 6227 SCHEME_V->interactive_repl = 1;
5879#endif
5880 6228
5881#if USE_PORTS 6229#if USE_PORTS
5882#if SHOW_ERROR_LINE 6230#if SHOW_ERROR_LINE
5883 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0; 6231 SCHEME_V->load_stack[0].rep.stdio.curr_line = 0;
5884 6232
… …
5888#endif 6236#endif
5889 6237
5890 SCHEME_V->inport = SCHEME_V->loadport; 6238 SCHEME_V->inport = SCHEME_V->loadport;
5891 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6239 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5892 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6240 Eval_Cycle (SCHEME_A_ OP_T0LVL);
6241
5893 set_typeflag (SCHEME_V->loadport, T_ATOM); 6242 set_typeflag (SCHEME_V->loadport, T_ATOM);
5894 6243
5895 if (SCHEME_V->retcode == 0) 6244 if (SCHEME_V->retcode == 0)
5896 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6245 SCHEME_V->retcode = SCHEME_V->nesting != 0;
5897} 6246}
5898 6247
5899void 6248ecb_cold void
5900scheme_load_string (SCHEME_P_ const char *cmd) 6249scheme_load_string (SCHEME_P_ const char *cmd)
5901{ 6250{
6251#if USE_PORTs
5902 dump_stack_reset (SCHEME_A); 6252 dump_stack_reset (SCHEME_A);
5903 SCHEME_V->envir = SCHEME_V->global_env; 6253 SCHEME_V->envir = SCHEME_V->global_env;
5904 SCHEME_V->file_i = 0; 6254 SCHEME_V->file_i = 0;
5905 SCHEME_V->load_stack[0].kind = port_input | port_string; 6255 SCHEME_V->load_stack[0].kind = port_input | port_string;
5906 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */ 6256 SCHEME_V->load_stack[0].rep.string.start = (char *)cmd; /* This func respects const */
5907 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd); 6257 SCHEME_V->load_stack[0].rep.string.past_the_end = (char *)cmd + strlen (cmd);
5908 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd; 6258 SCHEME_V->load_stack[0].rep.string.curr = (char *)cmd;
5909#if USE_PORTS
5910 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack); 6259 SCHEME_V->loadport = mk_port (SCHEME_A_ SCHEME_V->load_stack);
5911#endif
5912 SCHEME_V->retcode = 0; 6260 SCHEME_V->retcode = 0;
5913 SCHEME_V->interactive_repl = 0; 6261 SCHEME_V->interactive_repl = 0;
5914 SCHEME_V->inport = SCHEME_V->loadport; 6262 SCHEME_V->inport = SCHEME_V->loadport;
5915 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i); 6263 SCHEME_V->args = mk_integer (SCHEME_A_ SCHEME_V->file_i);
5916 Eval_Cycle (SCHEME_A_ OP_T0LVL); 6264 Eval_Cycle (SCHEME_A_ OP_T0LVL);
5917 set_typeflag (SCHEME_V->loadport, T_ATOM); 6265 set_typeflag (SCHEME_V->loadport, T_ATOM);
5918 6266
5919 if (SCHEME_V->retcode == 0) 6267 if (SCHEME_V->retcode == 0)
5920 SCHEME_V->retcode = SCHEME_V->nesting != 0; 6268 SCHEME_V->retcode = SCHEME_V->nesting != 0;
6269#else
6270 abort ();
6271#endif
5921} 6272}
5922 6273
5923void 6274ecb_cold void
5924scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value) 6275scheme_define (SCHEME_P_ pointer envir, pointer symbol, pointer value)
5925{ 6276{
5926 pointer x; 6277 pointer x;
5927 6278
5928 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0); 6279 x = find_slot_in_env (SCHEME_A_ envir, symbol, 0);
… …
5933 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value); 6284 new_slot_spec_in_env (SCHEME_A_ envir, symbol, value);
5934} 6285}
5935 6286
5936#if !STANDALONE 6287#if !STANDALONE
5937 6288
5938void 6289ecb_cold void
5939scheme_register_foreign_func (scheme * sc, scheme_registerable * sr) 6290scheme_register_foreign_func (scheme * sc, scheme_registerable * sr)
5940{ 6291{
5941 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f)); 6292 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ sr->name), mk_foreign_func (SCHEME_A_ sr->f));
5942} 6293}
5943 6294
5944void 6295ecb_cold void
5945scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count) 6296scheme_register_foreign_func_list (scheme * sc, scheme_registerable * list, int count)
5946{ 6297{
5947 int i; 6298 int i;
5948 6299
5949 for (i = 0; i < count; i++) 6300 for (i = 0; i < count; i++)
5950 scheme_register_foreign_func (SCHEME_A_ list + i); 6301 scheme_register_foreign_func (SCHEME_A_ list + i);
5951} 6302}
5952 6303
5953pointer 6304ecb_cold pointer
5954scheme_apply0 (SCHEME_P_ const char *procname) 6305scheme_apply0 (SCHEME_P_ const char *procname)
5955{ 6306{
5956 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL)); 6307 return scheme_eval (SCHEME_A_ cons (mk_symbol (SCHEME_A_ procname), NIL));
5957} 6308}
5958 6309
5959void 6310ecb_cold void
5960save_from_C_call (SCHEME_P) 6311save_from_C_call (SCHEME_P)
5961{ 6312{
5962 pointer saved_data = cons (car (S_SINK), 6313 pointer saved_data = cons (car (S_SINK),
5963 cons (SCHEME_V->envir, 6314 cons (SCHEME_V->envir,
5964 SCHEME_V->dump)); 6315 SCHEME_V->dump));
… …
5968 /* Truncate the dump stack so TS will return here when done, not 6319 /* Truncate the dump stack so TS will return here when done, not
5969 directly resume pre-C-call operations. */ 6320 directly resume pre-C-call operations. */
5970 dump_stack_reset (SCHEME_A); 6321 dump_stack_reset (SCHEME_A);
5971} 6322}
5972 6323
5973void 6324ecb_cold void
5974restore_from_C_call (SCHEME_P) 6325restore_from_C_call (SCHEME_P)
5975{ 6326{
5976 set_car (S_SINK, caar (SCHEME_V->c_nest)); 6327 set_car (S_SINK, caar (SCHEME_V->c_nest));
5977 SCHEME_V->envir = cadar (SCHEME_V->c_nest); 6328 SCHEME_V->envir = cadar (SCHEME_V->c_nest);
5978 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest)); 6329 SCHEME_V->dump = cdr (cdar (SCHEME_V->c_nest));
5979 /* Pop */ 6330 /* Pop */
5980 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest); 6331 SCHEME_V->c_nest = cdr (SCHEME_V->c_nest);
5981} 6332}
5982 6333
5983/* "func" and "args" are assumed to be already eval'ed. */ 6334/* "func" and "args" are assumed to be already eval'ed. */
5984pointer 6335ecb_cold pointer
5985scheme_call (SCHEME_P_ pointer func, pointer args) 6336scheme_call (SCHEME_P_ pointer func, pointer args)
5986{ 6337{
5987 int old_repl = SCHEME_V->interactive_repl; 6338 int old_repl = SCHEME_V->interactive_repl;
5988 6339
5989 SCHEME_V->interactive_repl = 0; 6340 SCHEME_V->interactive_repl = 0;
… …
5996 SCHEME_V->interactive_repl = old_repl; 6347 SCHEME_V->interactive_repl = old_repl;
5997 restore_from_C_call (SCHEME_A); 6348 restore_from_C_call (SCHEME_A);
5998 return SCHEME_V->value; 6349 return SCHEME_V->value;
5999} 6350}
6000 6351
6001pointer 6352ecb_cold pointer
6002scheme_eval (SCHEME_P_ pointer obj) 6353scheme_eval (SCHEME_P_ pointer obj)
6003{ 6354{
6004 int old_repl = SCHEME_V->interactive_repl; 6355 int old_repl = SCHEME_V->interactive_repl;
6005 6356
6006 SCHEME_V->interactive_repl = 0; 6357 SCHEME_V->interactive_repl = 0;
… …
6018 6369
6019/* ========== Main ========== */ 6370/* ========== Main ========== */
6020 6371
6021#if STANDALONE 6372#if STANDALONE
6022 6373
6023int 6374ecb_cold int
6024main (int argc, char **argv) 6375main (int argc, char **argv)
6025{ 6376{
6026# if USE_MULTIPLICITY 6377# if USE_MULTIPLICITY
6027 scheme ssc; 6378 scheme ssc;
6028 scheme *const SCHEME_V = &ssc; 6379 scheme *const SCHEME_V = &ssc;
… …
6030# endif 6381# endif
6031 int fin; 6382 int fin;
6032 char *file_name = InitFile; 6383 char *file_name = InitFile;
6033 int retcode; 6384 int retcode;
6034 int isfile = 1; 6385 int isfile = 1;
6386#if EXPERIMENT
6035 system ("ps v $PPID");//D 6387 system ("ps v $PPID");
6388#endif
6036 6389
6037 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6390 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6038 { 6391 {
6039 putstr (SCHEME_A_ "Usage: tinyscheme -?\n"); 6392 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6040 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n"); 6393 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
… …
6069 } 6422 }
6070#endif 6423#endif
6071 6424
6072 do 6425 do
6073 { 6426 {
6074#if USE_PORTS
6075 if (strcmp (file_name, "-") == 0) 6427 if (strcmp (file_name, "-") == 0)
6076 fin = STDIN_FILENO; 6428 fin = STDIN_FILENO;
6077 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0) 6429 else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
6078 { 6430 {
6079 pointer args = NIL; 6431 pointer args = NIL;
… …
6097 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args); 6449 scheme_define (SCHEME_A_ SCHEME_V->global_env, mk_symbol (SCHEME_A_ "*args*"), args);
6098 6450
6099 } 6451 }
6100 else 6452 else
6101 fin = open (file_name, O_RDONLY); 6453 fin = open (file_name, O_RDONLY);
6102#endif
6103 6454
6104 if (isfile && fin < 0) 6455 if (isfile && fin < 0)
6105 { 6456 {
6106 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); 6457 putstr (SCHEME_A_ "Could not open file ");
6458 putstr (SCHEME_A_ file_name);
6459 putcharacter (SCHEME_A_ '\n');
6107 } 6460 }
6108 else 6461 else
6109 { 6462 {
6110 if (isfile) 6463 if (isfile)
6111 scheme_load_named_file (SCHEME_A_ fin, file_name); 6464 scheme_load_named_file (SCHEME_A_ fin, file_name);
6112 else 6465 else
6113 scheme_load_string (SCHEME_A_ file_name); 6466 scheme_load_string (SCHEME_A_ file_name);
6114 6467
6115#if USE_PORTS
6116 if (!isfile || fin != STDIN_FILENO) 6468 if (!isfile || fin != STDIN_FILENO)
6117 { 6469 {
6118 if (SCHEME_V->retcode != 0) 6470 if (SCHEME_V->retcode != 0)
6119 { 6471 {
6120 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n"); 6472 putstr (SCHEME_A_ "Errors encountered reading ");
6473 putstr (SCHEME_A_ file_name);
6474 putcharacter (SCHEME_A_ '\n');
6121 } 6475 }
6122 6476
6123 if (isfile) 6477 if (isfile)
6124 close (fin); 6478 close (fin);
6125 } 6479 }
6126#endif
6127 } 6480 }
6128 6481
6129 file_name = *argv++; 6482 file_name = *argv++;
6130 } 6483 }
6131 while (file_name != 0); 6484 while (file_name != 0);

Diff Legend

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