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.48 by root, Mon Nov 30 13:07:34 2015 UTC vs.
Revision 1.53 by root, Tue Dec 1 02:21:49 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,
… …
266static int is_zero_rvalue (RVALUE x); 258static int is_zero_rvalue (RVALUE x);
267 259
268static num num_zero; 260static num num_zero;
269static num num_one; 261static num num_one;
270 262
263/* convert "pointer" to cell* / cell* to pointer */
264#define CELL(p) ((struct cell *)(p) + 0)
265#define POINTER(c) ((void *)((c) - 0))
266
271/* macros for cell operations */ 267/* macros for cell operations */
272#define typeflag(p) ((p)->flag + 0) 268#define typeflag(p) (CELL(p)->flag + 0)
273#define set_typeflag(p,v) ((p)->flag = (v)) 269#define set_typeflag(p,v) (CELL(p)->flag = (v))
274#define type(p) (typeflag (p) & T_MASKTYPE) 270#define type(p) (typeflag (p) & T_MASKTYPE)
275 271
276INTERFACE int 272INTERFACE int
277is_string (pointer p) 273is_string (pointer p)
278{ 274{
279 return type (p) == T_STRING; 275 return type (p) == T_STRING;
280} 276}
281 277
282#define strvalue(p) ((p)->object.string.svalue) 278#define strvalue(p) (CELL(p)->object.string.svalue)
283#define strlength(p) ((p)->object.string.length) 279#define strlength(p) (CELL(p)->object.string.length)
284 280
285INTERFACE int 281INTERFACE int
286is_vector (pointer p) 282is_vector (pointer p)
287{ 283{
288 return type (p) == T_VECTOR; 284 return type (p) == T_VECTOR;
289} 285}
290 286
291#define vecvalue(p) ((p)->object.vector.vvalue) 287#define vecvalue(p) (CELL(p)->object.vector.vvalue)
292#define veclength(p) ((p)->object.vector.length) 288#define veclength(p) (CELL(p)->object.vector.length)
293INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); 289INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
294INTERFACE pointer vector_get (pointer vec, uint32_t ielem); 290INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
295INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); 291INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
296 292
297INTERFACE int 293INTERFACE int
… …
323string_value (pointer p) 319string_value (pointer p)
324{ 320{
325 return strvalue (p); 321 return strvalue (p);
326} 322}
327 323
328#define ivalue_unchecked(p) (p)->object.ivalue 324#define ivalue_unchecked(p) CELL(p)->object.ivalue
329#define set_ivalue(p,v) (p)->object.ivalue = (v) 325#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
330 326
331#if USE_REAL 327#if USE_REAL
332#define rvalue_unchecked(p) (p)->object.rvalue 328#define rvalue_unchecked(p) CELL(p)->object.rvalue
333#define set_rvalue(p,v) (p)->object.rvalue = (v) 329#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
334#else 330#else
335#define rvalue_unchecked(p) (p)->object.ivalue 331#define rvalue_unchecked(p) CELL(p)->object.ivalue
336#define set_rvalue(p,v) (p)->object.ivalue = (v) 332#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
337#endif 333#endif
338 334
339INTERFACE long 335INTERFACE long
340charvalue (pointer p) 336charvalue (pointer p)
341{ 337{
342 return ivalue_unchecked (p); 338 return ivalue_unchecked (p);
343} 339}
344 340
341#define port(p) CELL(p)->object.port
342#define set_port(p,v) port(p) = (v)
345INTERFACE int 343INTERFACE int
346is_port (pointer p) 344is_port (pointer p)
347{ 345{
348 return type (p) == T_PORT; 346 return type (p) == T_PORT;
349} 347}
350 348
351INTERFACE int 349INTERFACE int
352is_inport (pointer p) 350is_inport (pointer p)
353{ 351{
354 return is_port (p) && p->object.port->kind & port_input; 352 return is_port (p) && port (p)->kind & port_input;
355} 353}
356 354
357INTERFACE int 355INTERFACE int
358is_outport (pointer p) 356is_outport (pointer p)
359{ 357{
360 return is_port (p) && p->object.port->kind & port_output; 358 return is_port (p) && port (p)->kind & port_output;
361} 359}
362 360
363INTERFACE int 361INTERFACE int
364is_pair (pointer p) 362is_pair (pointer p)
365{ 363{
366 return type (p) == T_PAIR; 364 return type (p) == T_PAIR;
367} 365}
368 366
369#define car(p) ((p)->object.cons.car + 0) 367#define car(p) (POINTER (CELL(p)->object.cons.car))
370#define cdr(p) ((p)->object.cons.cdr + 0) 368#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
371 369
372static pointer caar (pointer p) { return car (car (p)); } 370static pointer caar (pointer p) { return car (car (p)); }
373static pointer cadr (pointer p) { return car (cdr (p)); } 371static pointer cadr (pointer p) { return car (cdr (p)); }
374static pointer cdar (pointer p) { return cdr (car (p)); } 372static pointer cdar (pointer p) { return cdr (car (p)); }
375static pointer cddr (pointer p) { return cdr (cdr (p)); } 373static pointer cddr (pointer p) { return cdr (cdr (p)); }
… …
379static pointer cdaar (pointer p) { return cdr (car (car (p))); } 377static pointer cdaar (pointer p) { return cdr (car (car (p))); }
380 378
381INTERFACE void 379INTERFACE void
382set_car (pointer p, pointer q) 380set_car (pointer p, pointer q)
383{ 381{
384 p->object.cons.car = q; 382 CELL(p)->object.cons.car = CELL (q);
385} 383}
386 384
387INTERFACE void 385INTERFACE void
388set_cdr (pointer p, pointer q) 386set_cdr (pointer p, pointer q)
389{ 387{
390 p->object.cons.cdr = q; 388 CELL(p)->object.cons.cdr = CELL (q);
391} 389}
392 390
393INTERFACE pointer 391INTERFACE pointer
394pair_car (pointer p) 392pair_car (pointer p)
395{ 393{
… …
670 668
671static int file_push (SCHEME_P_ const char *fname); 669static int file_push (SCHEME_P_ const char *fname);
672static void file_pop (SCHEME_P); 670static void file_pop (SCHEME_P);
673static int file_interactive (SCHEME_P); 671static int file_interactive (SCHEME_P);
674ecb_inline int is_one_of (const char *s, int c); 672ecb_inline int is_one_of (const char *s, int c);
675static int alloc_cellseg (SCHEME_P_ int n); 673static int alloc_cellseg (SCHEME_P);
676ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 674ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
677static void finalize_cell (SCHEME_P_ pointer a); 675static void finalize_cell (SCHEME_P_ pointer a);
678static int count_consecutive_cells (pointer x, int needed); 676static int count_consecutive_cells (pointer x, int needed);
679static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 677static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
680static pointer mk_number (SCHEME_P_ const num n); 678static pointer mk_number (SCHEME_P_ const num n);
… …
914#endif 912#endif
915} 913}
916 914
917/* allocate new cell segment */ 915/* allocate new cell segment */
918static int 916static int
919alloc_cellseg (SCHEME_P_ int n) 917alloc_cellseg (SCHEME_P)
920{ 918{
921 pointer newp; 919 struct cell *newp;
922 pointer last; 920 struct cell *last;
923 pointer p; 921 struct cell *p;
924 char *cp; 922 char *cp;
925 long i; 923 long i;
926 int k; 924 int k;
927 925
928 static int segsize = CELL_SEGSIZE >> 1; 926 static int segsize = CELL_SEGSIZE >> 1;
929 segsize <<= 1; 927 segsize <<= 1;
930 928
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)); 929 cp = malloc (segsize * sizeof (struct cell));
937 930
938 if (!cp && USE_ERROR_CHECKING) 931 if (!cp && USE_ERROR_CHECKING)
939 return k; 932 return k;
940 933
941 i = ++SCHEME_V->last_cell_seg; 934 i = ++SCHEME_V->last_cell_seg;
942 SCHEME_V->alloc_seg[i] = cp; 935 SCHEME_V->alloc_seg[i] = cp;
943 936
944 newp = (pointer)cp; 937 newp = (struct cell *)cp;
945 SCHEME_V->cell_seg[i] = newp; 938 SCHEME_V->cell_seg[i] = newp;
946 SCHEME_V->cell_segsize[i] = segsize; 939 SCHEME_V->cell_segsize[i] = segsize;
947 SCHEME_V->fcells += segsize; 940 SCHEME_V->fcells += segsize;
948 last = newp + segsize - 1; 941 last = newp + segsize - 1;
949 942
950 for (p = newp; p <= last; p++) 943 for (p = newp; p <= last; p++)
951 { 944 {
945 pointer cp = POINTER (p);
952 set_typeflag (p, T_PAIR); 946 set_typeflag (cp, T_PAIR);
953 set_car (p, NIL); 947 set_car (cp, NIL);
954 set_cdr (p, p + 1); 948 set_cdr (cp, POINTER (p + 1));
955 } 949 }
956 950
957 set_cdr (last, SCHEME_V->free_cell); 951 set_cdr (POINTER (last), SCHEME_V->free_cell);
958 SCHEME_V->free_cell = newp; 952 SCHEME_V->free_cell = POINTER (newp);
959 }
960 953
961 return n; 954 return 1;
962} 955}
963 956
964/* get new cell. parameter a, b is marked by gc. */ 957/* get new cell. parameter a, b is marked by gc. */
965ecb_inline pointer 958ecb_inline pointer
966get_cell_x (SCHEME_P_ pointer a, pointer b) 959get_cell_x (SCHEME_P_ pointer a, pointer b)
… …
977 gc (SCHEME_A_ a, b); 970 gc (SCHEME_A_ a, b);
978 971
979 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 972 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
980 { 973 {
981 /* if only a few recovered, get more to avoid fruitless gc's */ 974 /* if only a few recovered, get more to avoid fruitless gc's */
982 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 975 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
983 { 976 {
984#if USE_ERROR_CHECKING 977#if USE_ERROR_CHECKING
985 SCHEME_V->no_memory = 1; 978 SCHEME_V->no_memory = 1;
986 return S_SINK; 979 return S_SINK;
987#endif 980#endif
… …
999 } 992 }
1000} 993}
1001 994
1002/* To retain recent allocs before interpreter knows about them - 995/* To retain recent allocs before interpreter knows about them -
1003 Tehom */ 996 Tehom */
1004
1005static void 997static void
1006push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 998push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1007{ 999{
1008 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 1000 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1009 1001
… …
1040 return S_SINK; 1032 return S_SINK;
1041 1033
1042 /* Record it as a vector so that gc understands it. */ 1034 /* Record it as a vector so that gc understands it. */
1043 set_typeflag (v, T_VECTOR | T_ATOM); 1035 set_typeflag (v, T_VECTOR | T_ATOM);
1044 1036
1045 v->object.vector.vvalue = e; 1037 CELL(v)->object.vector.vvalue = e;
1046 v->object.vector.length = len; 1038 CELL(v)->object.vector.length = len;
1047 fill_vector (v, 0, init); 1039 fill_vector (v, 0, init);
1048 push_recent_alloc (SCHEME_A_ v, NIL); 1040 push_recent_alloc (SCHEME_A_ v, NIL);
1049 1041
1050 return v; 1042 return v;
1051} 1043}
… …
1060static void 1052static void
1061check_cell_alloced (pointer p, int expect_alloced) 1053check_cell_alloced (pointer p, int expect_alloced)
1062{ 1054{
1063 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */ 1055 /* Can't use putstr(SCHEME_A_ str) because callers have no access to sc. */
1064 if (typeflag (p) & !expect_alloced) 1056 if (typeflag (p) & !expect_alloced)
1065 xwrstr ("Cell is already allocated!\n"); 1057 putstr (SCHEME_A_ "Cell is already allocated!\n");
1066 1058
1067 if (!(typeflag (p)) & expect_alloced) 1059 if (!(typeflag (p)) & expect_alloced)
1068 xwrstr ("Cell is not allocated!\n"); 1060 putstr (SCHEME_A_ "Cell is not allocated!\n");
1069} 1061}
1070 1062
1071static void 1063static void
1072check_range_alloced (pointer p, int n, int expect_alloced) 1064check_range_alloced (pointer p, int n, int expect_alloced)
1073{ 1065{
… …
1221mk_port (SCHEME_P_ port *p) 1213mk_port (SCHEME_P_ port *p)
1222{ 1214{
1223 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1215 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1224 1216
1225 set_typeflag (x, T_PORT | T_ATOM); 1217 set_typeflag (x, T_PORT | T_ATOM);
1226 x->object.port = p; 1218 set_port (x, p);
1227 1219
1228 return x; 1220 return x;
1229} 1221}
1230#endif 1222#endif
1231 1223
… …
1233mk_foreign_func (SCHEME_P_ foreign_func f) 1225mk_foreign_func (SCHEME_P_ foreign_func f)
1234{ 1226{
1235 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1227 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1236 1228
1237 set_typeflag (x, T_FOREIGN | T_ATOM); 1229 set_typeflag (x, T_FOREIGN | T_ATOM);
1238 x->object.ff = f; 1230 CELL(x)->object.ff = f;
1239 1231
1240 return x; 1232 return x;
1241} 1233}
1242 1234
1243INTERFACE pointer 1235INTERFACE pointer
… …
1634 1626
1635/* garbage collection. parameter a, b is marked. */ 1627/* garbage collection. parameter a, b is marked. */
1636static void 1628static void
1637gc (SCHEME_P_ pointer a, pointer b) 1629gc (SCHEME_P_ pointer a, pointer b)
1638{ 1630{
1639 pointer p;
1640 int i; 1631 int i;
1641 1632
1642 if (SCHEME_V->gc_verbose) 1633 if (SCHEME_V->gc_verbose)
1643 putstr (SCHEME_A_ "gc..."); 1634 putstr (SCHEME_A_ "gc...");
1644 1635
… …
1677 clrmark (NIL); 1668 clrmark (NIL);
1678 SCHEME_V->fcells = 0; 1669 SCHEME_V->fcells = 0;
1679 SCHEME_V->free_cell = NIL; 1670 SCHEME_V->free_cell = NIL;
1680 1671
1681 if (SCHEME_V->gc_verbose) 1672 if (SCHEME_V->gc_verbose)
1682 xwrstr ("freeing..."); 1673 putstr (SCHEME_A_ "freeing...");
1683 1674
1684 uint32_t total = 0; 1675 uint32_t total = 0;
1685 1676
1686 /* Here we scan the cells to build the free-list. */ 1677 /* Here we scan the cells to build the free-list. */
1687 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1678 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1688 { 1679 {
1689 pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; 1680 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1681 struct cell *p;
1690 total += SCHEME_V->cell_segsize [i]; 1682 total += SCHEME_V->cell_segsize [i];
1691 1683
1692 for (p = SCHEME_V->cell_seg[i]; p < end; ++p) 1684 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1693 { 1685 {
1686 pointer c = POINTER (p);
1687
1694 if (is_mark (p)) 1688 if (is_mark (c))
1695 clrmark (p); 1689 clrmark (c);
1696 else 1690 else
1697 { 1691 {
1698 /* reclaim cell */ 1692 /* reclaim cell */
1699 if (typeflag (p) != T_PAIR) 1693 if (typeflag (c) != T_PAIR)
1700 { 1694 {
1701 finalize_cell (SCHEME_A_ p); 1695 finalize_cell (SCHEME_A_ c);
1702 set_typeflag (p, T_PAIR); 1696 set_typeflag (c, T_PAIR);
1703 set_car (p, NIL); 1697 set_car (c, NIL);
1704 } 1698 }
1705 1699
1706 ++SCHEME_V->fcells; 1700 ++SCHEME_V->fcells;
1707 set_cdr (p, SCHEME_V->free_cell); 1701 set_cdr (c, SCHEME_V->free_cell);
1708 SCHEME_V->free_cell = p; 1702 SCHEME_V->free_cell = c;
1709 } 1703 }
1710 } 1704 }
1711 } 1705 }
1712 1706
1713 if (SCHEME_V->gc_verbose) 1707 if (SCHEME_V->gc_verbose)
1714 { 1708 {
1715 xwrstr ("done: "); xwrnum (SCHEME_V->fcells); xwrstr (" out of "); xwrnum (total); xwrstr (" cells were recovered.\n"); 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");
1716 } 1710 }
1717} 1711}
1718 1712
1719static void 1713static void
1720finalize_cell (SCHEME_P_ pointer a) 1714finalize_cell (SCHEME_P_ pointer a)
… …
1725 else if (is_vector (a)) 1719 else if (is_vector (a))
1726 free (vecvalue (a)); 1720 free (vecvalue (a));
1727#if USE_PORTS 1721#if USE_PORTS
1728 else if (is_port (a)) 1722 else if (is_port (a))
1729 { 1723 {
1730 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) 1724 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1731 port_close (SCHEME_A_ a, port_input | port_output); 1725 port_close (SCHEME_A_ a, port_input | port_output);
1732 1726
1733 free (a->object.port); 1727 free (port (a));
1734 } 1728 }
1735#endif 1729#endif
1736} 1730}
1737 1731
1738/* ========== Routines for Reading ========== */ 1732/* ========== Routines for Reading ========== */
… …
1754 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1748 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1755 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1749 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; 1750 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; 1751 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1758 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1752 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1759 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1753 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1760 1754
1761#if SHOW_ERROR_LINE 1755#if SHOW_ERROR_LINE
1762 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1756 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1763 1757
1764 if (fname) 1758 if (fname)
… …
1781 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1775 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1782#if USE_PORTS 1776#if USE_PORTS
1783 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1777 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1784#endif 1778#endif
1785 SCHEME_V->file_i--; 1779 SCHEME_V->file_i--;
1786 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1780 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1787 } 1781 }
1788} 1782}
1789 1783
1790static int 1784static int
1791file_interactive (SCHEME_P) 1785file_interactive (SCHEME_P)
1792{ 1786{
1793#if USE_PORTS 1787#if USE_PORTS
1794 return SCHEME_V->file_i == 0 1788 return SCHEME_V->file_i == 0
1795 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1789 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1796 && (SCHEME_V->inport->object.port->kind & port_file); 1790 && (port (SCHEME_V->inport)->kind & port_file);
1797#else 1791#else
1798 return 0; 1792 return 0;
1799#endif 1793#endif
1800} 1794}
1801 1795
… …
1935} 1929}
1936 1930
1937static void 1931static void
1938port_close (SCHEME_P_ pointer p, int flag) 1932port_close (SCHEME_P_ pointer p, int flag)
1939{ 1933{
1940 port *pt = p->object.port; 1934 port *pt = port (p);
1941 1935
1942 pt->kind &= ~flag; 1936 pt->kind &= ~flag;
1943 1937
1944 if ((pt->kind & (port_input | port_output)) == 0) 1938 if ((pt->kind & (port_input | port_output)) == 0)
1945 { 1939 {
… …
1966/* get new character from input file */ 1960/* get new character from input file */
1967static int 1961static int
1968inchar (SCHEME_P) 1962inchar (SCHEME_P)
1969{ 1963{
1970 int c; 1964 int c;
1971 port *pt; 1965 port *pt = port (SCHEME_V->inport);
1972
1973 pt = SCHEME_V->inport->object.port;
1974 1966
1975 if (pt->kind & port_saw_EOF) 1967 if (pt->kind & port_saw_EOF)
1976 return EOF; 1968 return EOF;
1977 1969
1978 c = basic_inchar (pt); 1970 c = basic_inchar (pt);
… …
2045 port *pt; 2037 port *pt;
2046 2038
2047 if (c == EOF) 2039 if (c == EOF)
2048 return; 2040 return;
2049 2041
2050 pt = SCHEME_V->inport->object.port; 2042 pt = port (SCHEME_V->inport);
2051 pt->unget = c; 2043 pt->unget = c;
2052#else 2044#else
2053 if (c == EOF) 2045 if (c == EOF)
2054 return; 2046 return;
2055 2047
… …
2083 2075
2084INTERFACE void 2076INTERFACE void
2085putstr (SCHEME_P_ const char *s) 2077putstr (SCHEME_P_ const char *s)
2086{ 2078{
2087#if USE_PORTS 2079#if USE_PORTS
2088 port *pt = SCHEME_V->outport->object.port; 2080 port *pt = port (SCHEME_V->outport);
2089 2081
2090 if (pt->kind & port_file) 2082 if (pt->kind & port_file)
2091 write (pt->rep.stdio.file, s, strlen (s)); 2083 write (pt->rep.stdio.file, s, strlen (s));
2092 else 2084 else
2093 for (; *s; s++) 2085 for (; *s; s++)
… …
2095 *pt->rep.string.curr++ = *s; 2087 *pt->rep.string.curr++ = *s;
2096 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt)) 2088 else if (pt->kind & port_srfi6 && realloc_port_string (SCHEME_A_ pt))
2097 *pt->rep.string.curr++ = *s; 2089 *pt->rep.string.curr++ = *s;
2098 2090
2099#else 2091#else
2100 xwrstr (s); 2092 write (pt->rep.stdio.file, s, strlen (s));
2101#endif 2093#endif
2102} 2094}
2103 2095
2104static void 2096static void
2105putchars (SCHEME_P_ const char *s, int len) 2097putchars (SCHEME_P_ const char *s, int len)
2106{ 2098{
2107#if USE_PORTS 2099#if USE_PORTS
2108 port *pt = SCHEME_V->outport->object.port; 2100 port *pt = port (SCHEME_V->outport);
2109 2101
2110 if (pt->kind & port_file) 2102 if (pt->kind & port_file)
2111 write (pt->rep.stdio.file, s, len); 2103 write (pt->rep.stdio.file, s, len);
2112 else 2104 else
2113 { 2105 {
… …
2127 2119
2128INTERFACE void 2120INTERFACE void
2129putcharacter (SCHEME_P_ int c) 2121putcharacter (SCHEME_P_ int c)
2130{ 2122{
2131#if USE_PORTS 2123#if USE_PORTS
2132 port *pt = SCHEME_V->outport->object.port; 2124 port *pt = port (SCHEME_V->outport);
2133 2125
2134 if (pt->kind & port_file) 2126 if (pt->kind & port_file)
2135 { 2127 {
2136 char cc = c; 2128 char cc = c;
2137 write (pt->rep.stdio.file, &cc, 1); 2129 write (pt->rep.stdio.file, &cc, 1);
… …
3079{ 3071{
3080 int nframes = (uintptr_t)SCHEME_V->dump; 3072 int nframes = (uintptr_t)SCHEME_V->dump;
3081 struct dump_stack_frame *next_frame; 3073 struct dump_stack_frame *next_frame;
3082 3074
3083 /* enough room for the next frame? */ 3075 /* enough room for the next frame? */
3084 if (nframes >= SCHEME_V->dump_size) 3076 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3085 { 3077 {
3086 SCHEME_V->dump_size += STACK_GROWTH; 3078 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); 3079 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3088 } 3080 }
3089 3081
… …
3345 s_return (S_T); 3337 s_return (S_T);
3346#endif 3338#endif
3347 case OP_LOAD: /* load */ 3339 case OP_LOAD: /* load */
3348 if (file_interactive (SCHEME_A)) 3340 if (file_interactive (SCHEME_A))
3349 { 3341 {
3350 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3342 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))); 3343 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3352 } 3344 }
3353 3345
3354 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3346 if (!file_push (SCHEME_A_ strvalue (car (args))))
3355 Error_1 ("unable to open", car (args)); 3347 Error_1 ("unable to open", car (args));
3356 else 3348 else
… …
3360 } 3352 }
3361 3353
3362 case OP_T0LVL: /* top level */ 3354 case OP_T0LVL: /* top level */
3363 3355
3364 /* If we reached the end of file, this loop is done. */ 3356 /* If we reached the end of file, this loop is done. */
3365 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3357 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3366 { 3358 {
3367 if (SCHEME_V->file_i == 0) 3359 if (SCHEME_V->file_i == 0)
3368 { 3360 {
3369 SCHEME_V->args = NIL; 3361 SCHEME_V->args = NIL;
3370 s_goto (OP_QUIT); 3362 s_goto (OP_QUIT);
… …
3448#endif 3440#endif
3449 if (is_symbol (SCHEME_V->code)) /* symbol */ 3441 if (is_symbol (SCHEME_V->code)) /* symbol */
3450 { 3442 {
3451 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3443 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3452 3444
3453 if (x != NIL) 3445 if (x == NIL)
3454 s_return (slot_value_in_env (x));
3455 else
3456 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3446 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3447
3448 s_return (slot_value_in_env (x));
3457 } 3449 }
3458 else if (is_pair (SCHEME_V->code)) 3450 else if (is_pair (SCHEME_V->code))
3459 { 3451 {
3460 x = car (SCHEME_V->code); 3452 x = car (SCHEME_V->code);
3461 3453
… …
3538 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3530 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3539 else if (is_foreign (SCHEME_V->code)) 3531 else if (is_foreign (SCHEME_V->code))
3540 { 3532 {
3541 /* Keep nested calls from GC'ing the arglist */ 3533 /* Keep nested calls from GC'ing the arglist */
3542 push_recent_alloc (SCHEME_A_ args, NIL); 3534 push_recent_alloc (SCHEME_A_ args, NIL);
3543 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3535 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3544 3536
3545 s_return (x); 3537 s_return (x);
3546 } 3538 }
3547 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3539 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3548 { 3540 {
… …
4642 } 4634 }
4643 else 4635 else
4644 s_return (SCHEME_V->code); 4636 s_return (SCHEME_V->code);
4645 4637
4646 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4638 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4647 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4639 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4648 s_return (SCHEME_V->value); 4640 s_return (SCHEME_V->value);
4649 4641
4650#if USE_PORTS 4642#if USE_PORTS
4651 4643
4652 case OP_WRITE: /* write */ 4644 case OP_WRITE: /* write */
… …
4797 SCHEME_V->gc_verbose = (a != S_F); 4789 SCHEME_V->gc_verbose = (a != S_F);
4798 s_retbool (was); 4790 s_retbool (was);
4799 } 4791 }
4800 4792
4801 case OP_NEWSEGMENT: /* new-segment */ 4793 case OP_NEWSEGMENT: /* new-segment */
4794#if 0
4802 if (!is_pair (args) || !is_number (a)) 4795 if (!is_pair (args) || !is_number (a))
4803 Error_0 ("new-segment: argument must be a number"); 4796 Error_0 ("new-segment: argument must be a number");
4804 4797#endif
4805 alloc_cellseg (SCHEME_A_ ivalue (a)); 4798 s_retbool (alloc_cellseg (SCHEME_A));
4806
4807 s_return (S_T);
4808 4799
4809 case OP_OBLIST: /* oblist */ 4800 case OP_OBLIST: /* oblist */
4810 s_return (oblist_all_symbols (SCHEME_A)); 4801 s_return (oblist_all_symbols (SCHEME_A));
4811 4802
4812#if USE_PORTS 4803#if USE_PORTS
… …
4882 s_return (p == NIL ? S_F : p); 4873 s_return (p == NIL ? S_F : p);
4883 } 4874 }
4884 4875
4885 case OP_GET_OUTSTRING: /* get-output-string */ 4876 case OP_GET_OUTSTRING: /* get-output-string */
4886 { 4877 {
4887 port *p; 4878 port *p = port (a);
4888 4879
4889 if ((p = a->object.port)->kind & port_string) 4880 if (p->kind & port_string)
4890 { 4881 {
4891 off_t size; 4882 off_t size;
4892 char *str; 4883 char *str;
4893 4884
4894 size = p->rep.string.curr - p->rep.string.start + 1; 4885 size = p->rep.string.curr - p->rep.string.start + 1;
… …
4999 int res; 4990 int res;
5000 4991
5001 if (is_pair (args)) 4992 if (is_pair (args))
5002 p = car (args); 4993 p = car (args);
5003 4994
5004 res = p->object.port->kind & port_string; 4995 res = port (p)->kind & port_string;
5005 4996
5006 s_retbool (res); 4997 s_retbool (res);
5007 } 4998 }
5008 4999
5009 case OP_SET_INPORT: /* set-input-port */ 5000 case OP_SET_INPORT: /* set-input-port */
… …
5549 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0)) 5540 if (ecb_expect_false (dispatch_funcs [pcd->func] (SCHEME_A_ SCHEME_V->op) != 0))
5550 return; 5541 return;
5551 5542
5552 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5543 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5553 { 5544 {
5554 xwrstr ("No memory!\n"); 5545 putstr (SCHEME_A_ "No memory!\n");
5555 return; 5546 return;
5556 } 5547 }
5557 } 5548 }
5558} 5549}
5559 5550
… …
5673scheme_init (SCHEME_P) 5664scheme_init (SCHEME_P)
5674{ 5665{
5675 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]); 5666 int i, n = sizeof (dispatch_table) / sizeof (dispatch_table[0]);
5676 pointer x; 5667 pointer x;
5677 5668
5669 /* this memset is not strictly correct, as we assume (intcache)
5670 * that memset 0 will also set pointers to 0, but memset does
5671 * of course not guarantee that. screw such systems.
5672 */
5678 memset (SCHEME_V, 0, sizeof (*SCHEME_V));//TODO !iso c 5673 memset (SCHEME_V, 0, sizeof (*SCHEME_V));
5679 5674
5680 num_set_fixnum (num_zero, 1); 5675 num_set_fixnum (num_zero, 1);
5681 num_set_ivalue (num_zero, 0); 5676 num_set_ivalue (num_zero, 0);
5682 num_set_fixnum (num_one, 1); 5677 num_set_fixnum (num_one, 1);
5683 num_set_ivalue (num_one, 1); 5678 num_set_ivalue (num_one, 1);
… …
5695 SCHEME_V->save_inport = NIL; 5690 SCHEME_V->save_inport = NIL;
5696 SCHEME_V->loadport = NIL; 5691 SCHEME_V->loadport = NIL;
5697 SCHEME_V->nesting = 0; 5692 SCHEME_V->nesting = 0;
5698 SCHEME_V->interactive_repl = 0; 5693 SCHEME_V->interactive_repl = 0;
5699 5694
5700 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 5695 if (!alloc_cellseg (SCHEME_A))
5701 { 5696 {
5702#if USE_ERROR_CHECKING 5697#if USE_ERROR_CHECKING
5703 SCHEME_V->no_memory = 1; 5698 SCHEME_V->no_memory = 1;
5704 return 0; 5699 return 0;
5705#endif 5700#endif
… …
6039 int isfile = 1; 6034 int isfile = 1;
6040 system ("ps v $PPID");//D 6035 system ("ps v $PPID");//D
6041 6036
6042 if (argc == 2 && strcmp (argv[1], "-?") == 0) 6037 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6043 { 6038 {
6044 xwrstr ("Usage: tinyscheme -?\n"); 6039 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6045 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6040 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6046 xwrstr ("followed by\n"); 6041 putstr (SCHEME_A_ "followed by\n");
6047 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6042 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6048 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6043 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6049 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6044 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6050 xwrstr ("Use - as filename for stdin.\n"); 6045 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6051 return 1; 6046 return 1;
6052 } 6047 }
6053 6048
6054 if (!scheme_init (SCHEME_A)) 6049 if (!scheme_init (SCHEME_A))
6055 { 6050 {
6056 xwrstr ("Could not initialize!\n"); 6051 putstr (SCHEME_A_ "Could not initialize!\n");
6057 return 2; 6052 return 2;
6058 } 6053 }
6059 6054
6060# if USE_PORTS 6055# if USE_PORTS
6061 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6056 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6106 fin = open (file_name, O_RDONLY); 6101 fin = open (file_name, O_RDONLY);
6107#endif 6102#endif
6108 6103
6109 if (isfile && fin < 0) 6104 if (isfile && fin < 0)
6110 { 6105 {
6111 xwrstr ("Could not open file "); xwrstr (file_name); xwrstr ("\n"); 6106 putstr (SCHEME_A_ "Could not open file "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6112 } 6107 }
6113 else 6108 else
6114 { 6109 {
6115 if (isfile) 6110 if (isfile)
6116 scheme_load_named_file (SCHEME_A_ fin, file_name); 6111 scheme_load_named_file (SCHEME_A_ fin, file_name);
… …
6120#if USE_PORTS 6115#if USE_PORTS
6121 if (!isfile || fin != STDIN_FILENO) 6116 if (!isfile || fin != STDIN_FILENO)
6122 { 6117 {
6123 if (SCHEME_V->retcode != 0) 6118 if (SCHEME_V->retcode != 0)
6124 { 6119 {
6125 xwrstr ("Errors encountered reading "); xwrstr (file_name); xwrstr ("\n"); 6120 putstr (SCHEME_A_ "Errors encountered reading "); putstr (SCHEME_A_ file_name); putstr (SCHEME_A_ "\n");
6126 } 6121 }
6127 6122
6128 if (isfile) 6123 if (isfile)
6129 close (fin); 6124 close (fin);
6130 } 6125 }

Diff Legend

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