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.49 by root, Mon Nov 30 13:09:56 2015 UTC vs.
Revision 1.54 by root, Tue Dec 1 02:42:35 2015 UTC

… …
18 * 18 *
19 */ 19 */
20 20
21#define EXPERIMENT 1 21#define EXPERIMENT 1
22 22
23#if 1
23#define PAGE_SIZE 4096 /* does not work on sparc/alpha */ 24#define PAGE_SIZE 4096 /* does not work on sparc/alpha */
24#include "malloc.c" 25#include "malloc.c"
26#endif
25 27
26#define SCHEME_SOURCE 28#define SCHEME_SOURCE
27#include "scheme-private.h" 29#include "scheme-private.h"
28#ifndef WIN32 30#ifndef WIN32
29# include <unistd.h> 31# include <unistd.h>
… …
79 81
80#define BACKQUOTE '`' 82#define BACKQUOTE '`'
81#define WHITESPACE " \t\r\n\v\f" 83#define WHITESPACE " \t\r\n\v\f"
82#define DELIMITERS "()\";" WHITESPACE 84#define DELIMITERS "()\";" WHITESPACE
83 85
84#define NIL (&SCHEME_V->xNIL) //TODO: make this 0? 86#define NIL POINTER (&SCHEME_V->xNIL)
85#define S_T (&SCHEME_V->xT) //TODO: magic ptr value? 87#define S_T POINTER (&SCHEME_V->xT)
86#define S_F (&SCHEME_V->xF) //TODO: magic ptr value? 88#define S_F POINTER (&SCHEME_V->xF)
87#define S_SINK (&SCHEME_V->xsink) 89#define S_SINK POINTER (&SCHEME_V->xsink)
88#define S_EOF (&SCHEME_V->xEOF_OBJ) 90#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
89 91
90#if !USE_MULTIPLICITY 92#if !USE_MULTIPLICITY
91static scheme sc; 93static scheme sc;
92#endif 94#endif
93 95
… …
101 } 103 }
102 104
103 char *p = s; 105 char *p = s;
104 106
105 do { 107 do {
106 *p++ = '0' + n % base; 108 *p++ = "0123456789abcdef"[n % base];
107 n /= base; 109 n /= base;
108 } while (n); 110 } while (n);
109 111
110 *p-- = 0; 112 *p-- = 0;
111 113
… …
121{ 123{
122 xbase (s, n, 10); 124 xbase (s, n, 10);
123} 125}
124 126
125static void 127static void
126xwrstr (const char *s) 128putnum (SCHEME_P_ long n)
127{
128 write (1, s, strlen (s));
129}
130
131static void
132xwrnum (long n)
133{ 129{
134 char buf[64]; 130 char buf[64];
135 131
136 xnum (buf, n); 132 xnum (buf, n);
137 xwrstr (buf); 133 putstr (SCHEME_A_ buf);
138} 134}
139 135
140static char 136static char
141xtoupper (char c) 137xtoupper (char c)
142{ 138{
… …
192# define prompt "ts> " 188# define prompt "ts> "
193#endif 189#endif
194 190
195#ifndef InitFile 191#ifndef InitFile
196# define InitFile "init.scm" 192# define InitFile "init.scm"
197#endif
198
199#ifndef FIRST_CELLSEGS
200# define FIRST_CELLSEGS 3
201#endif 193#endif
202 194
203enum scheme_types 195enum scheme_types
204{ 196{
205 T_INTEGER, 197 T_INTEGER,
… …
258static num num_op (enum num_op op, num a, num b); 250static num num_op (enum num_op op, num a, num b);
259static num num_intdiv (num a, num b); 251static num num_intdiv (num a, num b);
260static num num_rem (num a, num b); 252static num num_rem (num a, num b);
261static num num_mod (num a, num b); 253static num num_mod (num a, num b);
262 254
263#if USE_MATH
264static double round_per_R5RS (double x);
265#endif
266static int is_zero_rvalue (RVALUE x); 255static int is_zero_rvalue (RVALUE x);
267 256
268static num num_zero; 257static num num_zero;
269static num num_one; 258static num num_one;
270 259
260/* convert "pointer" to cell* / cell* to pointer */
261#define CELL(p) ((struct cell *)(p) + 0)
262#define POINTER(c) ((void *)((c) - 0))
263
271/* macros for cell operations */ 264/* macros for cell operations */
272#define typeflag(p) ((p)->flag + 0) 265#define typeflag(p) (CELL(p)->flag + 0)
273#define set_typeflag(p,v) ((p)->flag = (v)) 266#define set_typeflag(p,v) (CELL(p)->flag = (v))
274#define type(p) (typeflag (p) & T_MASKTYPE) 267#define type(p) (typeflag (p) & T_MASKTYPE)
275 268
276INTERFACE int 269INTERFACE int
277is_string (pointer p) 270is_string (pointer p)
278{ 271{
279 return type (p) == T_STRING; 272 return type (p) == T_STRING;
280} 273}
281 274
282#define strvalue(p) ((p)->object.string.svalue) 275#define strvalue(p) (CELL(p)->object.string.svalue)
283#define strlength(p) ((p)->object.string.length) 276#define strlength(p) (CELL(p)->object.string.length)
284 277
285INTERFACE int 278INTERFACE int
286is_vector (pointer p) 279is_vector (pointer p)
287{ 280{
288 return type (p) == T_VECTOR; 281 return type (p) == T_VECTOR;
289} 282}
290 283
291#define vecvalue(p) ((p)->object.vector.vvalue) 284#define vecvalue(p) (CELL(p)->object.vector.vvalue)
292#define veclength(p) ((p)->object.vector.length) 285#define veclength(p) (CELL(p)->object.vector.length)
293INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); 286INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
294INTERFACE pointer vector_get (pointer vec, uint32_t ielem); 287INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
295INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); 288INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
296 289
297INTERFACE int 290INTERFACE int
… …
323string_value (pointer p) 316string_value (pointer p)
324{ 317{
325 return strvalue (p); 318 return strvalue (p);
326} 319}
327 320
328#define ivalue_unchecked(p) (p)->object.ivalue 321#define ivalue_unchecked(p) CELL(p)->object.ivalue
329#define set_ivalue(p,v) (p)->object.ivalue = (v) 322#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
330 323
331#if USE_REAL 324#if USE_REAL
332#define rvalue_unchecked(p) (p)->object.rvalue 325#define rvalue_unchecked(p) CELL(p)->object.rvalue
333#define set_rvalue(p,v) (p)->object.rvalue = (v) 326#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
334#else 327#else
335#define rvalue_unchecked(p) (p)->object.ivalue 328#define rvalue_unchecked(p) CELL(p)->object.ivalue
336#define set_rvalue(p,v) (p)->object.ivalue = (v) 329#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
337#endif 330#endif
338 331
339INTERFACE long 332INTERFACE long
340charvalue (pointer p) 333charvalue (pointer p)
341{ 334{
342 return ivalue_unchecked (p); 335 return ivalue_unchecked (p);
343} 336}
344 337
338#define port(p) CELL(p)->object.port
339#define set_port(p,v) port(p) = (v)
345INTERFACE int 340INTERFACE int
346is_port (pointer p) 341is_port (pointer p)
347{ 342{
348 return type (p) == T_PORT; 343 return type (p) == T_PORT;
349} 344}
350 345
351INTERFACE int 346INTERFACE int
352is_inport (pointer p) 347is_inport (pointer p)
353{ 348{
354 return is_port (p) && p->object.port->kind & port_input; 349 return is_port (p) && port (p)->kind & port_input;
355} 350}
356 351
357INTERFACE int 352INTERFACE int
358is_outport (pointer p) 353is_outport (pointer p)
359{ 354{
360 return is_port (p) && p->object.port->kind & port_output; 355 return is_port (p) && port (p)->kind & port_output;
361} 356}
362 357
363INTERFACE int 358INTERFACE int
364is_pair (pointer p) 359is_pair (pointer p)
365{ 360{
366 return type (p) == T_PAIR; 361 return type (p) == T_PAIR;
367} 362}
368 363
369#define car(p) ((p)->object.cons.car + 0) 364#define car(p) (POINTER (CELL(p)->object.cons.car))
370#define cdr(p) ((p)->object.cons.cdr + 0) 365#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
371 366
372static pointer caar (pointer p) { return car (car (p)); } 367static pointer caar (pointer p) { return car (car (p)); }
373static pointer cadr (pointer p) { return car (cdr (p)); } 368static pointer cadr (pointer p) { return car (cdr (p)); }
374static pointer cdar (pointer p) { return cdr (car (p)); } 369static pointer cdar (pointer p) { return cdr (car (p)); }
375static pointer cddr (pointer p) { return cdr (cdr (p)); } 370static pointer cddr (pointer p) { return cdr (cdr (p)); }
… …
379static pointer cdaar (pointer p) { return cdr (car (car (p))); } 374static pointer cdaar (pointer p) { return cdr (car (car (p))); }
380 375
381INTERFACE void 376INTERFACE void
382set_car (pointer p, pointer q) 377set_car (pointer p, pointer q)
383{ 378{
384 p->object.cons.car = q; 379 CELL(p)->object.cons.car = CELL (q);
385} 380}
386 381
387INTERFACE void 382INTERFACE void
388set_cdr (pointer p, pointer q) 383set_cdr (pointer p, pointer q)
389{ 384{
390 p->object.cons.cdr = q; 385 CELL(p)->object.cons.cdr = CELL (q);
391} 386}
392 387
393INTERFACE pointer 388INTERFACE pointer
394pair_car (pointer p) 389pair_car (pointer p)
395{ 390{
… …
670 665
671static int file_push (SCHEME_P_ const char *fname); 666static int file_push (SCHEME_P_ const char *fname);
672static void file_pop (SCHEME_P); 667static void file_pop (SCHEME_P);
673static int file_interactive (SCHEME_P); 668static int file_interactive (SCHEME_P);
674ecb_inline int is_one_of (const char *s, int c); 669ecb_inline int is_one_of (const char *s, int c);
675static int alloc_cellseg (SCHEME_P_ int n); 670static int alloc_cellseg (SCHEME_P);
676ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 671ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
677static void finalize_cell (SCHEME_P_ pointer a); 672static void finalize_cell (SCHEME_P_ pointer a);
678static int count_consecutive_cells (pointer x, int needed); 673static int count_consecutive_cells (pointer x, int needed);
679static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 674static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
680static pointer mk_number (SCHEME_P_ const num n); 675static pointer mk_number (SCHEME_P_ const num n);
… …
874 } 869 }
875 870
876 return ret; 871 return ret;
877} 872}
878 873
879#if USE_MATH
880
881/* Round to nearest. Round to even if midway */
882static double
883round_per_R5RS (double x)
884{
885 double fl = floor (x);
886 double ce = ceil (x);
887 double dfl = x - fl;
888 double dce = ce - x;
889
890 if (dfl > dce)
891 return ce;
892 else if (dfl < dce)
893 return fl;
894 else
895 {
896 if (fmod (fl, 2) == 0) /* I imagine this holds */
897 return fl;
898 else
899 return ce;
900 }
901}
902#endif
903
904static int 874static int
905is_zero_rvalue (RVALUE x) 875is_zero_rvalue (RVALUE x)
906{ 876{
907 return x == 0; 877 return x == 0;
908#if 0 878#if 0
… …
914#endif 884#endif
915} 885}
916 886
917/* allocate new cell segment */ 887/* allocate new cell segment */
918static int 888static int
919alloc_cellseg (SCHEME_P_ int n) 889alloc_cellseg (SCHEME_P)
920{ 890{
921 pointer newp; 891 struct cell *newp;
922 pointer last; 892 struct cell *last;
923 pointer p; 893 struct cell *p;
924 char *cp; 894 char *cp;
925 long i; 895 long i;
926 int k; 896 int k;
927 897
928 static int segsize = CELL_SEGSIZE >> 1; 898 static int segsize = CELL_SEGSIZE >> 1;
929 segsize <<= 1; 899 segsize <<= 1;
930 900
931 for (k = 0; k < n; k++)
932 {
933 if (SCHEME_V->last_cell_seg >= CELL_NSEGMENT - 1)
934 return k;
935
936 cp = malloc (segsize * sizeof (struct cell)); 901 cp = malloc (segsize * sizeof (struct cell));
937 902
938 if (!cp && USE_ERROR_CHECKING) 903 if (!cp && USE_ERROR_CHECKING)
939 return k; 904 return k;
940 905
941 i = ++SCHEME_V->last_cell_seg; 906 i = ++SCHEME_V->last_cell_seg;
942 SCHEME_V->alloc_seg[i] = cp; 907 SCHEME_V->alloc_seg[i] = cp;
943 908
944 newp = (pointer)cp; 909 newp = (struct cell *)cp;
945 SCHEME_V->cell_seg[i] = newp; 910 SCHEME_V->cell_seg[i] = newp;
946 SCHEME_V->cell_segsize[i] = segsize; 911 SCHEME_V->cell_segsize[i] = segsize;
947 SCHEME_V->fcells += segsize; 912 SCHEME_V->fcells += segsize;
948 last = newp + segsize - 1; 913 last = newp + segsize - 1;
949 914
950 for (p = newp; p <= last; p++) 915 for (p = newp; p <= last; p++)
951 { 916 {
917 pointer cp = POINTER (p);
952 set_typeflag (p, T_PAIR); 918 set_typeflag (cp, T_PAIR);
953 set_car (p, NIL); 919 set_car (cp, NIL);
954 set_cdr (p, p + 1); 920 set_cdr (cp, POINTER (p + 1));
955 } 921 }
956 922
957 set_cdr (last, SCHEME_V->free_cell); 923 set_cdr (POINTER (last), SCHEME_V->free_cell);
958 SCHEME_V->free_cell = newp; 924 SCHEME_V->free_cell = POINTER (newp);
959 }
960 925
961 return n; 926 return 1;
962} 927}
963 928
964/* get new cell. parameter a, b is marked by gc. */ 929/* get new cell. parameter a, b is marked by gc. */
965ecb_inline pointer 930ecb_inline pointer
966get_cell_x (SCHEME_P_ pointer a, pointer b) 931get_cell_x (SCHEME_P_ pointer a, pointer b)
… …
977 gc (SCHEME_A_ a, b); 942 gc (SCHEME_A_ a, b);
978 943
979 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 944 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
980 { 945 {
981 /* if only a few recovered, get more to avoid fruitless gc's */ 946 /* if only a few recovered, get more to avoid fruitless gc's */
982 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 947 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
983 { 948 {
984#if USE_ERROR_CHECKING 949#if USE_ERROR_CHECKING
985 SCHEME_V->no_memory = 1; 950 SCHEME_V->no_memory = 1;
986 return S_SINK; 951 return S_SINK;
987#endif 952#endif
… …
999 } 964 }
1000} 965}
1001 966
1002/* To retain recent allocs before interpreter knows about them - 967/* To retain recent allocs before interpreter knows about them -
1003 Tehom */ 968 Tehom */
1004
1005static void 969static void
1006push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 970push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1007{ 971{
1008 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 972 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1009 973
… …
1040 return S_SINK; 1004 return S_SINK;
1041 1005
1042 /* Record it as a vector so that gc understands it. */ 1006 /* Record it as a vector so that gc understands it. */
1043 set_typeflag (v, T_VECTOR | T_ATOM); 1007 set_typeflag (v, T_VECTOR | T_ATOM);
1044 1008
1045 v->object.vector.vvalue = e; 1009 CELL(v)->object.vector.vvalue = e;
1046 v->object.vector.length = len; 1010 CELL(v)->object.vector.length = len;
1047 fill_vector (v, 0, init); 1011 fill_vector (v, 0, init);
1048 push_recent_alloc (SCHEME_A_ v, NIL); 1012 push_recent_alloc (SCHEME_A_ v, NIL);
1049 1013
1050 return v; 1014 return v;
1051} 1015}
… …
1060static void 1024static void
1061check_cell_alloced (pointer p, int expect_alloced) 1025check_cell_alloced (pointer p, int expect_alloced)
1062{ 1026{
1063 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ 1027 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1064 if (typeflag (p) & !expect_alloced) 1028 if (typeflag (p) & !expect_alloced)
1065 xwrstr ("Cell is already allocated!\n"); 1029 putstr (SCHEME_A_ "Cell is already allocated!\n");
1066 1030
1067 if (!(typeflag (p)) & expect_alloced) 1031 if (!(typeflag (p)) & expect_alloced)
1068 xwrstr ("Cell is not allocated!\n"); 1032 putstr (SCHEME_A_ "Cell is not allocated!\n");
1069} 1033}
1070 1034
1071static void 1035static void
1072check_range_alloced (pointer p, int n, int expect_alloced) 1036check_range_alloced (pointer p, int n, int expect_alloced)
1073{ 1037{
… …
1221mk_port (SCHEME_P_ port *p) 1185mk_port (SCHEME_P_ port *p)
1222{ 1186{
1223 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1187 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1224 1188
1225 set_typeflag (x, T_PORT | T_ATOM); 1189 set_typeflag (x, T_PORT | T_ATOM);
1226 x->object.port = p; 1190 set_port (x, p);
1227 1191
1228 return x; 1192 return x;
1229} 1193}
1230#endif 1194#endif
1231 1195
… …
1233mk_foreign_func (SCHEME_P_ foreign_func f) 1197mk_foreign_func (SCHEME_P_ foreign_func f)
1234{ 1198{
1235 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1199 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1236 1200
1237 set_typeflag (x, T_FOREIGN | T_ATOM); 1201 set_typeflag (x, T_FOREIGN | T_ATOM);
1238 x->object.ff = f; 1202 CELL(x)->object.ff = f;
1239 1203
1240 return x; 1204 return x;
1241} 1205}
1242 1206
1243INTERFACE pointer 1207INTERFACE pointer
… …
1634 1598
1635/* garbage collection. parameter a, b is marked. */ 1599/* garbage collection. parameter a, b is marked. */
1636static void 1600static void
1637gc (SCHEME_P_ pointer a, pointer b) 1601gc (SCHEME_P_ pointer a, pointer b)
1638{ 1602{
1639 pointer p;
1640 int i; 1603 int i;
1641 1604
1642 if (SCHEME_V->gc_verbose) 1605 if (SCHEME_V->gc_verbose)
1643 putstr (SCHEME_A_ "gc..."); 1606 putstr (SCHEME_A_ "gc...");
1644 1607
… …
1677 clrmark (NIL); 1640 clrmark (NIL);
1678 SCHEME_V->fcells = 0; 1641 SCHEME_V->fcells = 0;
1679 SCHEME_V->free_cell = NIL; 1642 SCHEME_V->free_cell = NIL;
1680 1643
1681 if (SCHEME_V->gc_verbose) 1644 if (SCHEME_V->gc_verbose)
1682 xwrstr ("freeing..."); 1645 putstr (SCHEME_A_ "freeing...");
1683 1646
1684 uint32_t total = 0; 1647 uint32_t total = 0;
1685 1648
1686 /* Here we scan the cells to build the free-list. */ 1649 /* Here we scan the cells to build the free-list. */
1687 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1650 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1688 { 1651 {
1689 pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; 1652 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1653 struct cell *p;
1690 total += SCHEME_V->cell_segsize [i]; 1654 total += SCHEME_V->cell_segsize [i];
1691 1655
1692 for (p = SCHEME_V->cell_seg[i]; p < end; ++p) 1656 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1693 { 1657 {
1658 pointer c = POINTER (p);
1659
1694 if (is_mark (p)) 1660 if (is_mark (c))
1695 clrmark (p); 1661 clrmark (c);
1696 else 1662 else
1697 { 1663 {
1698 /* reclaim cell */ 1664 /* reclaim cell */
1699 if (typeflag (p) != T_PAIR) 1665 if (typeflag (c) != T_PAIR)
1700 { 1666 {
1701 finalize_cell (SCHEME_A_ p); 1667 finalize_cell (SCHEME_A_ c);
1702 set_typeflag (p, T_PAIR); 1668 set_typeflag (c, T_PAIR);
1703 set_car (p, NIL); 1669 set_car (c, NIL);
1704 } 1670 }
1705 1671
1706 ++SCHEME_V->fcells; 1672 ++SCHEME_V->fcells;
1707 set_cdr (p, SCHEME_V->free_cell); 1673 set_cdr (c, SCHEME_V->free_cell);
1708 SCHEME_V->free_cell = p; 1674 SCHEME_V->free_cell = c;
1709 } 1675 }
1710 } 1676 }
1711 } 1677 }
1712 1678
1713 if (SCHEME_V->gc_verbose) 1679 if (SCHEME_V->gc_verbose)
1714 { 1680 {
1715 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n"); 1681 putstr (SCHEME_A_ "done: "); putnum (SCHEME_A_ SCHEME_V->fcells); putstr (SCHEME_A_ " out of "); putnum (SCHEME_A_ total); putstr (SCHEME_A_ " cells were recovered.\n");
1716 } 1682 }
1717} 1683}
1718 1684
1719static void 1685static void
1720finalize_cell (SCHEME_P_ pointer a) 1686finalize_cell (SCHEME_P_ pointer a)
… …
1725 else if (is_vector (a)) 1691 else if (is_vector (a))
1726 free (vecvalue (a)); 1692 free (vecvalue (a));
1727#if USE_PORTS 1693#if USE_PORTS
1728 else if (is_port (a)) 1694 else if (is_port (a))
1729 { 1695 {
1730 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) 1696 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1731 port_close (SCHEME_A_ a, port_input | port_output); 1697 port_close (SCHEME_A_ a, port_input | port_output);
1732 1698
1733 free (a->object.port); 1699 free (port (a));
1734 } 1700 }
1735#endif 1701#endif
1736} 1702}
1737 1703
1738/* ========== Routines for Reading ========== */ 1704/* ========== Routines for Reading ========== */
… …
1754 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1720 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1755 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1721 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input;
1756 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin; 1722 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.file = fin;
1757 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1; 1723 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1758 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1724 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1759 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1725 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1760 1726
1761#if SHOW_ERROR_LINE 1727#if SHOW_ERROR_LINE
1762 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1728 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1763 1729
1764 if (fname) 1730 if (fname)
… …
1781 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1747 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1782#if USE_PORTS 1748#if USE_PORTS
1783 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1749 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1784#endif 1750#endif
1785 SCHEME_V->file_i--; 1751 SCHEME_V->file_i--;
1786 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1752 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1787 } 1753 }
1788} 1754}
1789 1755
1790static int 1756static int
1791file_interactive (SCHEME_P) 1757file_interactive (SCHEME_P)
1792{ 1758{
1793#if USE_PORTS 1759#if USE_PORTS
1794 return SCHEME_V->file_i == 0 1760 return SCHEME_V->file_i == 0
1795 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1761 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1796 && (SCHEME_V->inport->object.port->kind & port_file); 1762 && (port (SCHEME_V->inport)->kind & port_file);
1797#else 1763#else
1798 return 0; 1764 return 0;
1799#endif 1765#endif
1800} 1766}
1801 1767
… …
1935} 1901}
1936 1902
1937static void 1903static void
1938port_close (SCHEME_P_ pointer p, int flag) 1904port_close (SCHEME_P_ pointer p, int flag)
1939{ 1905{
1940 port *pt = p->object.port; 1906 port *pt = port (p);
1941 1907
1942 pt->kind &= ~flag; 1908 pt->kind &= ~flag;
1943 1909
1944 if ((pt->kind & (port_input | port_output)) == 0) 1910 if ((pt->kind & (port_input | port_output)) == 0)
1945 { 1911 {
… …
1966/* get new character from input file */ 1932/* get new character from input file */
1967static int 1933static int
1968inchar (SCHEME_P) 1934inchar (SCHEME_P)
1969{ 1935{
1970 int c; 1936 int c;
1971 port *pt; 1937 port *pt = port (SCHEME_V->inport);
1972
1973 pt = SCHEME_V->inport->object.port;
1974 1938
1975 if (pt->kind & port_saw_EOF) 1939 if (pt->kind & port_saw_EOF)
1976 return EOF; 1940 return EOF;
1977 1941
1978 c = basic_inchar (pt); 1942 c = basic_inchar (pt);
… …
2045 port *pt; 2009 port *pt;
2046 2010
2047 if (c == EOF) 2011 if (c == EOF)
2048 return; 2012 return;
2049 2013
2050 pt = SCHEME_V->inport->object.port; 2014 pt = port (SCHEME_V->inport);
2051 pt->unget = c; 2015 pt->unget = c;
2052#else 2016#else
2053 if (c == EOF) 2017 if (c == EOF)
2054 return; 2018 return;
2055 2019
… …
2083 2047
2084INTERFACE void 2048INTERFACE void
2085putstr (SCHEME_P_ const char *s) 2049putstr (SCHEME_P_ const char *s)
2086{ 2050{
2087#if USE_PORTS 2051#if USE_PORTS
2088 port *pt = SCHEME_V->outport->object.port; 2052 port *pt = port (SCHEME_V->outport);
2089 2053
2090 if (pt->kind & port_file) 2054 if (pt->kind & port_file)
2091 write (pt->rep.stdio.file, s, strlen (s)); 2055 write (pt->rep.stdio.file, s, strlen (s));
2092 else 2056 else
2093 for (; *s; s++) 2057 for (; *s; s++)
… …
2095 *pt->rep.string.curr++ = *s; 2059 *pt->rep.string.curr++ = *s;
2096 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) 2060 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2097 *pt->rep.string.curr++ = *s; 2061 *pt->rep.string.curr++ = *s;
2098 2062
2099#else 2063#else
2100 xwrstr (s); 2064 write (pt->rep.stdio.file, s, strlen (s));
2101#endif 2065#endif
2102} 2066}
2103 2067
2104static void 2068static void
2105putchars (SCHEME_P_ const char *s, int len) 2069putchars (SCHEME_P_ const char *s, int len)
2106{ 2070{
2107#if USE_PORTS 2071#if USE_PORTS
2108 port *pt = SCHEME_V->outport->object.port; 2072 port *pt = port (SCHEME_V->outport);
2109 2073
2110 if (pt->kind & port_file) 2074 if (pt->kind & port_file)
2111 write (pt->rep.stdio.file, s, len); 2075 write (pt->rep.stdio.file, s, len);
2112 else 2076 else
2113 { 2077 {
… …
2127 2091
2128INTERFACE void 2092INTERFACE void
2129putcharacter (SCHEME_P_ int c) 2093putcharacter (SCHEME_P_ int c)
2130{ 2094{
2131#if USE_PORTS 2095#if USE_PORTS
2132 port *pt = SCHEME_V->outport->object.port; 2096 port *pt = port (SCHEME_V->outport);
2133 2097
2134 if (pt->kind & port_file) 2098 if (pt->kind & port_file)
2135 { 2099 {
2136 char cc = c; 2100 char cc = c;
2137 write (pt->rep.stdio.file, &cc, 1); 2101 write (pt->rep.stdio.file, &cc, 1);
… …
3079{ 3043{
3080 int nframes = (uintptr_t)SCHEME_V->dump; 3044 int nframes = (uintptr_t)SCHEME_V->dump;
3081 struct dump_stack_frame *next_frame; 3045 struct dump_stack_frame *next_frame;
3082 3046
3083 /* enough room for the next frame? */ 3047 /* enough room for the next frame? */
3084 if (nframes >= SCHEME_V->dump_size) 3048 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3085 { 3049 {
3086 SCHEME_V->dump_size += STACK_GROWTH; 3050 SCHEME_V->dump_size += STACK_GROWTH;
3087 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size); 3051 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3088 } 3052 }
3089 3053
… …
3345 s_return (S_T); 3309 s_return (S_T);
3346#endif 3310#endif
3347 case OP_LOAD: /* load */ 3311 case OP_LOAD: /* load */
3348 if (file_interactive (SCHEME_A)) 3312 if (file_interactive (SCHEME_A))
3349 { 3313 {
3350 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3314 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
3351 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3315 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3352 } 3316 }
3353 3317
3354 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3318 if (!file_push (SCHEME_A_ strvalue (car (args))))
3355 Error_1 ("unable to open", car (args)); 3319 Error_1 ("unable to open", car (args));
3356 else 3320 else
… …
3360 } 3324 }
3361 3325
3362 case OP_T0LVL: /* top level */ 3326 case OP_T0LVL: /* top level */
3363 3327
3364 /* If we reached the end of file, this loop is done. */ 3328 /* If we reached the end of file, this loop is done. */
3365 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3329 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3366 { 3330 {
3367 if (SCHEME_V->file_i == 0) 3331 if (SCHEME_V->file_i == 0)
3368 { 3332 {
3369 SCHEME_V->args = NIL; 3333 SCHEME_V->args = NIL;
3370 s_goto (OP_QUIT); 3334 s_goto (OP_QUIT);
… …
3448#endif 3412#endif
3449 if (is_symbol (SCHEME_V->code)) /* symbol */ 3413 if (is_symbol (SCHEME_V->code)) /* symbol */
3450 { 3414 {
3451 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3415 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3452 3416
3453 if (x != NIL) 3417 if (x == NIL)
3454 s_return (slot_value_in_env (x));
3455 else
3456 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3418 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3419
3420 s_return (slot_value_in_env (x));
3457 } 3421 }
3458 else if (is_pair (SCHEME_V->code)) 3422 else if (is_pair (SCHEME_V->code))
3459 { 3423 {
3460 x = car (SCHEME_V->code); 3424 x = car (SCHEME_V->code);
3461 3425
… …
3538 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3502 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3539 else if (is_foreign (SCHEME_V->code)) 3503 else if (is_foreign (SCHEME_V->code))
3540 { 3504 {
3541 /* Keep nested calls from GC'ing the arglist */ 3505 /* Keep nested calls from GC'ing the arglist */
3542 push_recent_alloc (SCHEME_A_ args, NIL); 3506 push_recent_alloc (SCHEME_A_ args, NIL);
3543 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3507 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3544 3508
3545 s_return (x); 3509 s_return (x);
3546 } 3510 }
3547 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3511 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3548 { 3512 {
… …
4099 s_return (mk_real (SCHEME_A_ result)); 4063 s_return (mk_real (SCHEME_A_ result));
4100 else 4064 else
4101 s_return (mk_integer (SCHEME_A_ result)); 4065 s_return (mk_integer (SCHEME_A_ result));
4102 } 4066 }
4103 4067
4104 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x)))); 4068 case OP_FLOOR: s_return (mk_real (SCHEME_A_ floor (rvalue (x))));
4105 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x)))); 4069 case OP_CEILING: s_return (mk_real (SCHEME_A_ ceil (rvalue (x))));
4106
4107 case OP_TRUNCATE:
4108 {
4109 RVALUE n = rvalue (x);
4110 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4111 }
4112
4113 case OP_ROUND:
4114 if (is_integer (x))
4115 s_return (x);
4116
4117 s_return (mk_real (SCHEME_A_ round_per_R5RS (rvalue (x)))); 4070 case OP_TRUNCATE: s_return (mk_real (SCHEME_A_ trunc (rvalue (x))));
4071 case OP_ROUND: s_return (mk_real (SCHEME_A_ nearbyint (rvalue (x))));
4118#endif 4072#endif
4119 4073
4120 case OP_ADD: /* + */ 4074 case OP_ADD: /* + */
4121 v = num_zero; 4075 v = num_zero;
4122 4076
… …
4642 } 4596 }
4643 else 4597 else
4644 s_return (SCHEME_V->code); 4598 s_return (SCHEME_V->code);
4645 4599
4646 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4600 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4647 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4601 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4648 s_return (SCHEME_V->value); 4602 s_return (SCHEME_V->value);
4649 4603
4650#if USE_PORTS 4604#if USE_PORTS
4651 4605
4652 case OP_WRITE: /* write */ 4606 case OP_WRITE: /* write */
… …
4797 SCHEME_V->gc_verbose = (a != S_F); 4751 SCHEME_V->gc_verbose = (a != S_F);
4798 s_retbool (was); 4752 s_retbool (was);
4799 } 4753 }
4800 4754
4801 case OP_NEWSEGMENT: /* new-segment */ 4755 case OP_NEWSEGMENT: /* new-segment */
4756#if 0
4802 if (!is_pair (args) || !is_number (a)) 4757 if (!is_pair (args) || !is_number (a))
4803 Error_0 ("new-segment: argument must be a number"); 4758 Error_0 ("new-segment: argument must be a number");
4804 4759#endif
4805 alloc_cellseg (SCHEME_A_ ivalue (a)); 4760 s_retbool (alloc_cellseg (SCHEME_A));
4806
4807 s_return (S_T);
4808 4761
4809 case OP_OBLIST: /* oblist */ 4762 case OP_OBLIST: /* oblist */
4810 s_return (oblist_all_symbols (SCHEME_A)); 4763 s_return (oblist_all_symbols (SCHEME_A));
4811 4764
4812#if USE_PORTS 4765#if USE_PORTS
… …
4882 s_return (p == NIL ? S_F : p); 4835 s_return (p == NIL ? S_F : p);
4883 } 4836 }
4884 4837
4885 case OP_GET_OUTSTRING: /* get-output-string */ 4838 case OP_GET_OUTSTRING: /* get-output-string */
4886 { 4839 {
4887 port *p; 4840 port *p = port (a);
4888 4841
4889 if ((p = a->object.port)->kind & port_string) 4842 if (p->kind & port_string)
4890 { 4843 {
4891 off_t size; 4844 off_t size;
4892 char *str; 4845 char *str;
4893 4846
4894 size = p->rep.string.curr - p->rep.string.start + 1; 4847 size = p->rep.string.curr - p->rep.string.start + 1;
… …
4999 int res; 4952 int res;
5000 4953
5001 if (is_pair (args)) 4954 if (is_pair (args))
5002 p = car (args); 4955 p = car (args);
5003 4956
5004 res = p->object.port->kind & port_string; 4957 res = port (p)->kind & port_string;
5005 4958
5006 s_retbool (res); 4959 s_retbool (res);
5007 } 4960 }
5008 4961
5009 case OP_SET_INPORT: /* set-input-port */ 4962 case OP_SET_INPORT: /* set-input-port */
… …
5549 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) 5502 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5550 return; 5503 return;
5551 5504
5552 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5505 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5553 { 5506 {
5554 xwrstr ("No memory!\n"); 5507 putstr (SCHEME_A_ "No memory!\n");
5555 return; 5508 return;
5556 } 5509 }
5557 } 5510 }
5558} 5511}
5559 5512
… …
5699 SCHEME_V->save_inport = NIL; 5652 SCHEME_V->save_inport = NIL;
5700 SCHEME_V->loadport = NIL; 5653 SCHEME_V->loadport = NIL;
5701 SCHEME_V->nesting = 0; 5654 SCHEME_V->nesting = 0;
5702 SCHEME_V->interactive_repl = 0; 5655 SCHEME_V->interactive_repl = 0;
5703 5656
5704 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 5657 if (!alloc_cellseg (SCHEME_A))
5705 { 5658 {
5706#if USE_ERROR_CHECKING 5659#if USE_ERROR_CHECKING
5707 SCHEME_V->no_memory = 1; 5660 SCHEME_V->no_memory = 1;
5708 return 0; 5661 return 0;
5709#endif 5662#endif
… …
6043 int isfile = 1; 5996 int isfile = 1;
6044 system ("ps v $PPID");//D 5997 system ("ps v $PPID");//D
6045 5998
6046 if (argc == 2 && strcmp (argv[1], "-?") == 0) 5999 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6047 { 6000 {
6048 xwrstr ("Usage: tinyscheme -?\n"); 6001 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6049 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6002 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6050 xwrstr ("followed by\n"); 6003 putstr (SCHEME_A_ "followed by\n");
6051 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6004 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6052 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6005 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6053 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6006 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6054 xwrstr ("Use - as filename for stdin.\n"); 6007 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6055 return 1; 6008 return 1;
6056 } 6009 }
6057 6010
6058 if (!scheme_init (SCHEME_A)) 6011 if (!scheme_init (SCHEME_A))
6059 { 6012 {
6060 xwrstr ("Could not initialize!\n"); 6013 putstr (SCHEME_A_ "Could not initialize!\n");
6061 return 2; 6014 return 2;
6062 } 6015 }
6063 6016
6064# if USE_PORTS 6017# if USE_PORTS
6065 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6018 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6110 fin = open (file_name, O_RDONLY); 6063 fin = open (file_name, O_RDONLY);
6111#endif 6064#endif
6112 6065
6113 if (isfile && fin < 0) 6066 if (isfile && fin < 0)
6114 { 6067 {
6115 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6068 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6116 } 6069 }
6117 else 6070 else
6118 { 6071 {
6119 if (isfile) 6072 if (isfile)
6120 scheme_load_named_file (SCHEME_A_ fin, file_name); 6073 scheme_load_named_file (SCHEME_A_ fin, file_name);
… …
6124#if USE_PORTS 6077#if USE_PORTS
6125 if (!isfile || fin != STDIN_FILENO) 6078 if (!isfile || fin != STDIN_FILENO)
6126 { 6079 {
6127 if (SCHEME_V->retcode != 0) 6080 if (SCHEME_V->retcode != 0)
6128 { 6081 {
6129 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6082 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6130 } 6083 }
6131 6084
6132 if (isfile) 6085 if (isfile)
6133 close (fin); 6086 close (fin);
6134 } 6087 }

Diff Legend

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