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.50 by root, Tue Dec 1 00:47:54 2015 UTC vs.
Revision 1.51 by root, Tue Dec 1 01:54:27 2015 UTC

… …
79 79
80#define BACKQUOTE '`' 80#define BACKQUOTE '`'
81#define WHITESPACE " \t\r\n\v\f" 81#define WHITESPACE " \t\r\n\v\f"
82#define DELIMITERS "()\";" WHITESPACE 82#define DELIMITERS "()\";" WHITESPACE
83 83
84#define NIL (&SCHEME_V->xNIL) 84#define NIL POINTER (&SCHEME_V->xNIL)
85#define S_T (&SCHEME_V->xT) 85#define S_T POINTER (&SCHEME_V->xT)
86#define S_F (&SCHEME_V->xF) 86#define S_F POINTER (&SCHEME_V->xF)
87#define S_SINK (&SCHEME_V->xsink) 87#define S_SINK POINTER (&SCHEME_V->xsink)
88#define S_EOF (&SCHEME_V->xEOF_OBJ) 88#define S_EOF POINTER (&SCHEME_V->xEOF_OBJ)
89 89
90#if !USE_MULTIPLICITY 90#if !USE_MULTIPLICITY
91static scheme sc; 91static scheme sc;
92#endif 92#endif
93 93
… …
192# define prompt "ts> " 192# define prompt "ts> "
193#endif 193#endif
194 194
195#ifndef InitFile 195#ifndef InitFile
196# define InitFile "init.scm" 196# define InitFile "init.scm"
197#endif
198
199#ifndef FIRST_CELLSEGS
200# define FIRST_CELLSEGS 3
201#endif 197#endif
202 198
203enum scheme_types 199enum scheme_types
204{ 200{
205 T_INTEGER, 201 T_INTEGER,
… …
266static int is_zero_rvalue (RVALUE x); 262static int is_zero_rvalue (RVALUE x);
267 263
268static num num_zero; 264static num num_zero;
269static num num_one; 265static num num_one;
270 266
267/* convert "pointer" to cell* / cell* to pointer */
268#define CELL(p) ((struct cell *)(p) + 0)
269#define POINTER(c) ((void *)((c) - 0))
270
271/* macros for cell operations */ 271/* macros for cell operations */
272#define typeflag(p) ((p)->flag + 0) 272#define typeflag(p) (CELL(p)->flag + 0)
273#define set_typeflag(p,v) ((p)->flag = (v)) 273#define set_typeflag(p,v) (CELL(p)->flag = (v))
274#define type(p) (typeflag (p) & T_MASKTYPE) 274#define type(p) (typeflag (p) & T_MASKTYPE)
275 275
276INTERFACE int 276INTERFACE int
277is_string (pointer p) 277is_string (pointer p)
278{ 278{
279 return type (p) == T_STRING; 279 return type (p) == T_STRING;
280} 280}
281 281
282#define strvalue(p) ((p)->object.string.svalue) 282#define strvalue(p) (CELL(p)->object.string.svalue)
283#define strlength(p) ((p)->object.string.length) 283#define strlength(p) (CELL(p)->object.string.length)
284 284
285INTERFACE int 285INTERFACE int
286is_vector (pointer p) 286is_vector (pointer p)
287{ 287{
288 return type (p) == T_VECTOR; 288 return type (p) == T_VECTOR;
289} 289}
290 290
291#define vecvalue(p) ((p)->object.vector.vvalue) 291#define vecvalue(p) (CELL(p)->object.vector.vvalue)
292#define veclength(p) ((p)->object.vector.length) 292#define veclength(p) (CELL(p)->object.vector.length)
293INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj); 293INTERFACE void fill_vector (pointer vec, uint32_t start, pointer obj);
294INTERFACE pointer vector_get (pointer vec, uint32_t ielem); 294INTERFACE pointer vector_get (pointer vec, uint32_t ielem);
295INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a); 295INTERFACE void vector_set (pointer vec, uint32_t ielem, pointer a);
296 296
297INTERFACE int 297INTERFACE int
… …
323string_value (pointer p) 323string_value (pointer p)
324{ 324{
325 return strvalue (p); 325 return strvalue (p);
326} 326}
327 327
328#define ivalue_unchecked(p) (p)->object.ivalue 328#define ivalue_unchecked(p) CELL(p)->object.ivalue
329#define set_ivalue(p,v) (p)->object.ivalue = (v) 329#define set_ivalue(p,v) CELL(p)->object.ivalue = (v)
330 330
331#if USE_REAL 331#if USE_REAL
332#define rvalue_unchecked(p) (p)->object.rvalue 332#define rvalue_unchecked(p) CELL(p)->object.rvalue
333#define set_rvalue(p,v) (p)->object.rvalue = (v) 333#define set_rvalue(p,v) CELL(p)->object.rvalue = (v)
334#else 334#else
335#define rvalue_unchecked(p) (p)->object.ivalue 335#define rvalue_unchecked(p) CELL(p)->object.ivalue
336#define set_rvalue(p,v) (p)->object.ivalue = (v) 336#define set_rvalue(p,v) CELL(p)->object.ivalue = (v)
337#endif 337#endif
338 338
339INTERFACE long 339INTERFACE long
340charvalue (pointer p) 340charvalue (pointer p)
341{ 341{
342 return ivalue_unchecked (p); 342 return ivalue_unchecked (p);
343} 343}
344 344
345#define port(p) CELL(p)->object.port
346#define set_port(p,v) port(p) = (v)
345INTERFACE int 347INTERFACE int
346is_port (pointer p) 348is_port (pointer p)
347{ 349{
348 return type (p) == T_PORT; 350 return type (p) == T_PORT;
349} 351}
350 352
351INTERFACE int 353INTERFACE int
352is_inport (pointer p) 354is_inport (pointer p)
353{ 355{
354 return is_port (p) && p->object.port->kind & port_input; 356 return is_port (p) && port (p)->kind & port_input;
355} 357}
356 358
357INTERFACE int 359INTERFACE int
358is_outport (pointer p) 360is_outport (pointer p)
359{ 361{
360 return is_port (p) && p->object.port->kind & port_output; 362 return is_port (p) && port (p)->kind & port_output;
361} 363}
362 364
363INTERFACE int 365INTERFACE int
364is_pair (pointer p) 366is_pair (pointer p)
365{ 367{
366 return type (p) == T_PAIR; 368 return type (p) == T_PAIR;
367} 369}
368 370
369#define car(p) ((p)->object.cons.car + 0) 371#define car(p) (POINTER (CELL(p)->object.cons.car))
370#define cdr(p) ((p)->object.cons.cdr + 0) 372#define cdr(p) (POINTER (CELL(p)->object.cons.cdr))
371 373
372static pointer caar (pointer p) { return car (car (p)); } 374static pointer caar (pointer p) { return car (car (p)); }
373static pointer cadr (pointer p) { return car (cdr (p)); } 375static pointer cadr (pointer p) { return car (cdr (p)); }
374static pointer cdar (pointer p) { return cdr (car (p)); } 376static pointer cdar (pointer p) { return cdr (car (p)); }
375static pointer cddr (pointer p) { return cdr (cdr (p)); } 377static pointer cddr (pointer p) { return cdr (cdr (p)); }
… …
379static pointer cdaar (pointer p) { return cdr (car (car (p))); } 381static pointer cdaar (pointer p) { return cdr (car (car (p))); }
380 382
381INTERFACE void 383INTERFACE void
382set_car (pointer p, pointer q) 384set_car (pointer p, pointer q)
383{ 385{
384 p->object.cons.car = q; 386 CELL(p)->object.cons.car = CELL (q);
385} 387}
386 388
387INTERFACE void 389INTERFACE void
388set_cdr (pointer p, pointer q) 390set_cdr (pointer p, pointer q)
389{ 391{
390 p->object.cons.cdr = q; 392 CELL(p)->object.cons.cdr = CELL (q);
391} 393}
392 394
393INTERFACE pointer 395INTERFACE pointer
394pair_car (pointer p) 396pair_car (pointer p)
395{ 397{
… …
670 672
671static int file_push (SCHEME_P_ const char *fname); 673static int file_push (SCHEME_P_ const char *fname);
672static void file_pop (SCHEME_P); 674static void file_pop (SCHEME_P);
673static int file_interactive (SCHEME_P); 675static int file_interactive (SCHEME_P);
674ecb_inline int is_one_of (const char *s, int c); 676ecb_inline int is_one_of (const char *s, int c);
675static int alloc_cellseg (SCHEME_P_ int n); 677static int alloc_cellseg (SCHEME_P);
676ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b); 678ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
677static void finalize_cell (SCHEME_P_ pointer a); 679static void finalize_cell (SCHEME_P_ pointer a);
678static int count_consecutive_cells (pointer x, int needed); 680static int count_consecutive_cells (pointer x, int needed);
679static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all); 681static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
680static pointer mk_number (SCHEME_P_ const num n); 682static pointer mk_number (SCHEME_P_ const num n);
… …
914#endif 916#endif
915} 917}
916 918
917/* allocate new cell segment */ 919/* allocate new cell segment */
918static int 920static int
919alloc_cellseg (SCHEME_P_ int n) 921alloc_cellseg (SCHEME_P)
920{ 922{
921 pointer newp; 923 struct cell *newp;
922 pointer last; 924 struct cell *last;
923 pointer p; 925 struct cell *p;
924 char *cp; 926 char *cp;
925 long i; 927 long i;
926 int k; 928 int k;
927 929
928 static int segsize = CELL_SEGSIZE >> 1; 930 static int segsize = CELL_SEGSIZE >> 1;
929 segsize <<= 1; 931 segsize <<= 1;
930 932
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)); 933 cp = malloc (segsize * sizeof (struct cell));
937 934
938 if (!cp && USE_ERROR_CHECKING) 935 if (!cp && USE_ERROR_CHECKING)
939 return k; 936 return k;
940 937
941 i = ++SCHEME_V->last_cell_seg; 938 i = ++SCHEME_V->last_cell_seg;
942 SCHEME_V->alloc_seg[i] = cp; 939 SCHEME_V->alloc_seg[i] = cp;
943 940
944 newp = (pointer)cp; 941 newp = (struct cell *)cp;
945 SCHEME_V->cell_seg[i] = newp; 942 SCHEME_V->cell_seg[i] = newp;
946 SCHEME_V->cell_segsize[i] = segsize; 943 SCHEME_V->cell_segsize[i] = segsize;
947 SCHEME_V->fcells += segsize; 944 SCHEME_V->fcells += segsize;
948 last = newp + segsize - 1; 945 last = newp + segsize - 1;
949 946
950 for (p = newp; p <= last; p++) 947 for (p = newp; p <= last; p++)
951 { 948 {
949 pointer cp = POINTER (p);
952 set_typeflag (p, T_PAIR); 950 set_typeflag (cp, T_PAIR);
953 set_car (p, NIL); 951 set_car (cp, NIL);
954 set_cdr (p, p + 1); 952 set_cdr (cp, POINTER (p + 1));
955 } 953 }
956 954
957 set_cdr (last, SCHEME_V->free_cell); 955 set_cdr (POINTER (last), SCHEME_V->free_cell);
958 SCHEME_V->free_cell = newp; 956 SCHEME_V->free_cell = POINTER (newp);
959 }
960 957
961 return n; 958 return 1;
962} 959}
963 960
964/* get new cell. parameter a, b is marked by gc. */ 961/* get new cell. parameter a, b is marked by gc. */
965ecb_inline pointer 962ecb_inline pointer
966get_cell_x (SCHEME_P_ pointer a, pointer b) 963get_cell_x (SCHEME_P_ pointer a, pointer b)
… …
977 gc (SCHEME_A_ a, b); 974 gc (SCHEME_A_ a, b);
978 975
979 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL) 976 if (SCHEME_V->fcells < min_to_be_recovered || SCHEME_V->free_cell == NIL)
980 { 977 {
981 /* if only a few recovered, get more to avoid fruitless gc's */ 978 /* if only a few recovered, get more to avoid fruitless gc's */
982 if (!alloc_cellseg (SCHEME_A_ 1) && SCHEME_V->free_cell == NIL) 979 if (!alloc_cellseg (SCHEME_A) && SCHEME_V->free_cell == NIL)
983 { 980 {
984#if USE_ERROR_CHECKING 981#if USE_ERROR_CHECKING
985 SCHEME_V->no_memory = 1; 982 SCHEME_V->no_memory = 1;
986 return S_SINK; 983 return S_SINK;
987#endif 984#endif
… …
999 } 996 }
1000} 997}
1001 998
1002/* To retain recent allocs before interpreter knows about them - 999/* To retain recent allocs before interpreter knows about them -
1003 Tehom */ 1000 Tehom */
1004
1005static void 1001static void
1006push_recent_alloc (SCHEME_P_ pointer recent, pointer extra) 1002push_recent_alloc (SCHEME_P_ pointer recent, pointer extra)
1007{ 1003{
1008 pointer holder = get_cell_x (SCHEME_A_ recent, extra); 1004 pointer holder = get_cell_x (SCHEME_A_ recent, extra);
1009 1005
… …
1040 return S_SINK; 1036 return S_SINK;
1041 1037
1042 /* Record it as a vector so that gc understands it. */ 1038 /* Record it as a vector so that gc understands it. */
1043 set_typeflag (v, T_VECTOR | T_ATOM); 1039 set_typeflag (v, T_VECTOR | T_ATOM);
1044 1040
1045 v->object.vector.vvalue = e; 1041 CELL(v)->object.vector.vvalue = e;
1046 v->object.vector.length = len; 1042 CELL(v)->object.vector.length = len;
1047 fill_vector (v, 0, init); 1043 fill_vector (v, 0, init);
1048 push_recent_alloc (SCHEME_A_ v, NIL); 1044 push_recent_alloc (SCHEME_A_ v, NIL);
1049 1045
1050 return v; 1046 return v;
1051} 1047}
… …
1221mk_port (SCHEME_P_ port *p) 1217mk_port (SCHEME_P_ port *p)
1222{ 1218{
1223 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1219 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1224 1220
1225 set_typeflag (x, T_PORT | T_ATOM); 1221 set_typeflag (x, T_PORT | T_ATOM);
1226 x->object.port = p; 1222 set_port (x, p);
1227 1223
1228 return x; 1224 return x;
1229} 1225}
1230#endif 1226#endif
1231 1227
… …
1233mk_foreign_func (SCHEME_P_ foreign_func f) 1229mk_foreign_func (SCHEME_P_ foreign_func f)
1234{ 1230{
1235 pointer x = get_cell (SCHEME_A_ NIL, NIL); 1231 pointer x = get_cell (SCHEME_A_ NIL, NIL);
1236 1232
1237 set_typeflag (x, T_FOREIGN | T_ATOM); 1233 set_typeflag (x, T_FOREIGN | T_ATOM);
1238 x->object.ff = f; 1234 CELL(x)->object.ff = f;
1239 1235
1240 return x; 1236 return x;
1241} 1237}
1242 1238
1243INTERFACE pointer 1239INTERFACE pointer
… …
1634 1630
1635/* garbage collection. parameter a, b is marked. */ 1631/* garbage collection. parameter a, b is marked. */
1636static void 1632static void
1637gc (SCHEME_P_ pointer a, pointer b) 1633gc (SCHEME_P_ pointer a, pointer b)
1638{ 1634{
1639 pointer p;
1640 int i; 1635 int i;
1641 1636
1642 if (SCHEME_V->gc_verbose) 1637 if (SCHEME_V->gc_verbose)
1643 putstr (SCHEME_A_ "gc..."); 1638 putstr (SCHEME_A_ "gc...");
1644 1639
… …
1684 uint32_t total = 0; 1679 uint32_t total = 0;
1685 1680
1686 /* Here we scan the cells to build the free-list. */ 1681 /* Here we scan the cells to build the free-list. */
1687 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1682 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
1688 { 1683 {
1689 pointer end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i]; 1684 struct cell *end = SCHEME_V->cell_seg[i] + SCHEME_V->cell_segsize [i];
1685 struct cell *p;
1690 total += SCHEME_V->cell_segsize [i]; 1686 total += SCHEME_V->cell_segsize [i];
1691 1687
1692 for (p = SCHEME_V->cell_seg[i]; p < end; ++p) 1688 for (p = SCHEME_V->cell_seg[i]; p < end; ++p)
1693 { 1689 {
1690 pointer c = POINTER (p);
1691
1694 if (is_mark (p)) 1692 if (is_mark (c))
1695 clrmark (p); 1693 clrmark (c);
1696 else 1694 else
1697 { 1695 {
1698 /* reclaim cell */ 1696 /* reclaim cell */
1699 if (typeflag (p) != T_PAIR) 1697 if (typeflag (c) != T_PAIR)
1700 { 1698 {
1701 finalize_cell (SCHEME_A_ p); 1699 finalize_cell (SCHEME_A_ c);
1702 set_typeflag (p, T_PAIR); 1700 set_typeflag (c, T_PAIR);
1703 set_car (p, NIL); 1701 set_car (c, NIL);
1704 } 1702 }
1705 1703
1706 ++SCHEME_V->fcells; 1704 ++SCHEME_V->fcells;
1707 set_cdr (p, SCHEME_V->free_cell); 1705 set_cdr (c, SCHEME_V->free_cell);
1708 SCHEME_V->free_cell = p; 1706 SCHEME_V->free_cell = c;
1709 } 1707 }
1710 } 1708 }
1711 } 1709 }
1712 1710
1713 if (SCHEME_V->gc_verbose) 1711 if (SCHEME_V->gc_verbose)
… …
1725 else if (is_vector (a)) 1723 else if (is_vector (a))
1726 free (vecvalue (a)); 1724 free (vecvalue (a));
1727#if USE_PORTS 1725#if USE_PORTS
1728 else if (is_port (a)) 1726 else if (is_port (a))
1729 { 1727 {
1730 if (a->object.port->kind & port_file && a->object.port->rep.stdio.closeit) 1728 if (port(a)->kind & port_file && port (a)->rep.stdio.closeit)
1731 port_close (SCHEME_A_ a, port_input | port_output); 1729 port_close (SCHEME_A_ a, port_input | port_output);
1732 1730
1733 free (a->object.port); 1731 free (port (a));
1734 } 1732 }
1735#endif 1733#endif
1736} 1734}
1737 1735
1738/* ========== Routines for Reading ========== */ 1736/* ========== Routines for Reading ========== */
… …
1754 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1; 1752 SCHEME_V->load_stack[SCHEME_V->file_i].unget = -1;
1755 SCHEME_V->load_stack[SCHEME_V->file_i].kind = port_file | port_input; 1753 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; 1754 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; 1755 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.closeit = 1;
1758 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0; 1756 SCHEME_V->nesting_stack[SCHEME_V->file_i] = 0;
1759 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1757 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1760 1758
1761#if SHOW_ERROR_LINE 1759#if SHOW_ERROR_LINE
1762 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0; 1760 SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line = 0;
1763 1761
1764 if (fname) 1762 if (fname)
… …
1781 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i]; 1779 SCHEME_V->nesting = SCHEME_V->nesting_stack[SCHEME_V->file_i];
1782#if USE_PORTS 1780#if USE_PORTS
1783 port_close (SCHEME_A_ SCHEME_V->loadport, port_input); 1781 port_close (SCHEME_A_ SCHEME_V->loadport, port_input);
1784#endif 1782#endif
1785 SCHEME_V->file_i--; 1783 SCHEME_V->file_i--;
1786 SCHEME_V->loadport->object.port = SCHEME_V->load_stack + SCHEME_V->file_i; 1784 set_port (SCHEME_V->loadport, SCHEME_V->load_stack + SCHEME_V->file_i);
1787 } 1785 }
1788} 1786}
1789 1787
1790static int 1788static int
1791file_interactive (SCHEME_P) 1789file_interactive (SCHEME_P)
1792{ 1790{
1793#if USE_PORTS 1791#if USE_PORTS
1794 return SCHEME_V->file_i == 0 1792 return SCHEME_V->file_i == 0
1795 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO 1793 && SCHEME_V->load_stack[0].rep.stdio.file == STDIN_FILENO
1796 && (SCHEME_V->inport->object.port->kind & port_file); 1794 && (port (SCHEME_V->inport)->kind & port_file);
1797#else 1795#else
1798 return 0; 1796 return 0;
1799#endif 1797#endif
1800} 1798}
1801 1799
… …
1935} 1933}
1936 1934
1937static void 1935static void
1938port_close (SCHEME_P_ pointer p, int flag) 1936port_close (SCHEME_P_ pointer p, int flag)
1939{ 1937{
1940 port *pt = p->object.port; 1938 port *pt = port (p);
1941 1939
1942 pt->kind &= ~flag; 1940 pt->kind &= ~flag;
1943 1941
1944 if ((pt->kind & (port_input | port_output)) == 0) 1942 if ((pt->kind & (port_input | port_output)) == 0)
1945 { 1943 {
… …
1966/* get new character from input file */ 1964/* get new character from input file */
1967static int 1965static int
1968inchar (SCHEME_P) 1966inchar (SCHEME_P)
1969{ 1967{
1970 int c; 1968 int c;
1971 port *pt; 1969 port *pt = port (SCHEME_V->inport);
1972
1973 pt = SCHEME_V->inport->object.port;
1974 1970
1975 if (pt->kind & port_saw_EOF) 1971 if (pt->kind & port_saw_EOF)
1976 return EOF; 1972 return EOF;
1977 1973
1978 c = basic_inchar (pt); 1974 c = basic_inchar (pt);
… …
2045 port *pt; 2041 port *pt;
2046 2042
2047 if (c == EOF) 2043 if (c == EOF)
2048 return; 2044 return;
2049 2045
2050 pt = SCHEME_V->inport->object.port; 2046 pt = port (SCHEME_V->inport);
2051 pt->unget = c; 2047 pt->unget = c;
2052#else 2048#else
2053 if (c == EOF) 2049 if (c == EOF)
2054 return; 2050 return;
2055 2051
… …
2083 2079
2084INTERFACE void 2080INTERFACE void
2085putstr (SCHEME_P_ const char *s) 2081putstr (SCHEME_P_ const char *s)
2086{ 2082{
2087#if USE_PORTS 2083#if USE_PORTS
2088 port *pt = SCHEME_V->outport->object.port; 2084 port *pt = port (SCHEME_V->outport);
2089 2085
2090 if (pt->kind & port_file) 2086 if (pt->kind & port_file)
2091 write (pt->rep.stdio.file, s, strlen (s)); 2087 write (pt->rep.stdio.file, s, strlen (s));
2092 else 2088 else
2093 for (; *s; s++) 2089 for (; *s; s++)
… …
2103 2099
2104static void 2100static void
2105putchars (SCHEME_P_ const char *s, int len) 2101putchars (SCHEME_P_ const char *s, int len)
2106{ 2102{
2107#if USE_PORTS 2103#if USE_PORTS
2108 port *pt = SCHEME_V->outport->object.port; 2104 port *pt = port (SCHEME_V->outport);
2109 2105
2110 if (pt->kind & port_file) 2106 if (pt->kind & port_file)
2111 write (pt->rep.stdio.file, s, len); 2107 write (pt->rep.stdio.file, s, len);
2112 else 2108 else
2113 { 2109 {
… …
2127 2123
2128INTERFACE void 2124INTERFACE void
2129putcharacter (SCHEME_P_ int c) 2125putcharacter (SCHEME_P_ int c)
2130{ 2126{
2131#if USE_PORTS 2127#if USE_PORTS
2132 port *pt = SCHEME_V->outport->object.port; 2128 port *pt = port (SCHEME_V->outport);
2133 2129
2134 if (pt->kind & port_file) 2130 if (pt->kind & port_file)
2135 { 2131 {
2136 char cc = c; 2132 char cc = c;
2137 write (pt->rep.stdio.file, &cc, 1); 2133 write (pt->rep.stdio.file, &cc, 1);
… …
3079{ 3075{
3080 int nframes = (uintptr_t)SCHEME_V->dump; 3076 int nframes = (uintptr_t)SCHEME_V->dump;
3081 struct dump_stack_frame *next_frame; 3077 struct dump_stack_frame *next_frame;
3082 3078
3083 /* enough room for the next frame? */ 3079 /* enough room for the next frame? */
3084 if (nframes >= SCHEME_V->dump_size) 3080 if (ecb_expect_false (nframes >= SCHEME_V->dump_size))
3085 { 3081 {
3086 SCHEME_V->dump_size += STACK_GROWTH; 3082 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); 3083 SCHEME_V->dump_base = realloc (SCHEME_V->dump_base, sizeof (struct dump_stack_frame) * SCHEME_V->dump_size);
3088 } 3084 }
3089 3085
… …
3346#endif 3342#endif
3347 case OP_LOAD: /* load */ 3343 case OP_LOAD: /* load */
3348 if (file_interactive (SCHEME_A)) 3344 if (file_interactive (SCHEME_A))
3349 { 3345 {
3350 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3346 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
3351 //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args))); 3347 //D fprintf (port (SCHEME_V->outport)->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
3352 } 3348 }
3353 3349
3354 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3350 if (!file_push (SCHEME_A_ strvalue (car (args))))
3355 Error_1 ("unable to open", car (args)); 3351 Error_1 ("unable to open", car (args));
3356 else 3352 else
… …
3360 } 3356 }
3361 3357
3362 case OP_T0LVL: /* top level */ 3358 case OP_T0LVL: /* top level */
3363 3359
3364 /* If we reached the end of file, this loop is done. */ 3360 /* If we reached the end of file, this loop is done. */
3365 if (SCHEME_V->loadport->object.port->kind & port_saw_EOF) 3361 if (port (SCHEME_V->loadport)->kind & port_saw_EOF)
3366 { 3362 {
3367 if (SCHEME_V->file_i == 0) 3363 if (SCHEME_V->file_i == 0)
3368 { 3364 {
3369 SCHEME_V->args = NIL; 3365 SCHEME_V->args = NIL;
3370 s_goto (OP_QUIT); 3366 s_goto (OP_QUIT);
… …
3448#endif 3444#endif
3449 if (is_symbol (SCHEME_V->code)) /* symbol */ 3445 if (is_symbol (SCHEME_V->code)) /* symbol */
3450 { 3446 {
3451 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1); 3447 x = find_slot_in_env (SCHEME_A_ SCHEME_V->envir, SCHEME_V->code, 1);
3452 3448
3453 if (x != NIL) 3449 if (x == NIL)
3454 s_return (slot_value_in_env (x));
3455 else
3456 Error_1 ("eval: unbound variable:", SCHEME_V->code); 3450 Error_1 ("eval: unbound variable:", SCHEME_V->code);
3451
3452 s_return (slot_value_in_env (x));
3457 } 3453 }
3458 else if (is_pair (SCHEME_V->code)) 3454 else if (is_pair (SCHEME_V->code))
3459 { 3455 {
3460 x = car (SCHEME_V->code); 3456 x = car (SCHEME_V->code);
3461 3457
… …
3538 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */ 3534 s_goto (procnum (SCHEME_V->code)); /* PROCEDURE */
3539 else if (is_foreign (SCHEME_V->code)) 3535 else if (is_foreign (SCHEME_V->code))
3540 { 3536 {
3541 /* Keep nested calls from GC'ing the arglist */ 3537 /* Keep nested calls from GC'ing the arglist */
3542 push_recent_alloc (SCHEME_A_ args, NIL); 3538 push_recent_alloc (SCHEME_A_ args, NIL);
3543 x = SCHEME_V->code->object.ff (SCHEME_A_ args); 3539 x = CELL(SCHEME_V->code)->object.ff (SCHEME_A_ args);
3544 3540
3545 s_return (x); 3541 s_return (x);
3546 } 3542 }
3547 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */ 3543 else if (is_closure (SCHEME_V->code) || is_macro (SCHEME_V->code) || is_promise (SCHEME_V->code)) /* CLOSURE */
3548 { 3544 {
… …
4642 } 4638 }
4643 else 4639 else
4644 s_return (SCHEME_V->code); 4640 s_return (SCHEME_V->code);
4645 4641
4646 case OP_SAVE_FORCED: /* Save forced value replacing promise */ 4642 case OP_SAVE_FORCED: /* Save forced value replacing promise */
4647 memcpy (SCHEME_V->code, SCHEME_V->value, sizeof (struct cell)); 4643 *CELL (SCHEME_V->code) = *CELL (SCHEME_V->value);
4648 s_return (SCHEME_V->value); 4644 s_return (SCHEME_V->value);
4649 4645
4650#if USE_PORTS 4646#if USE_PORTS
4651 4647
4652 case OP_WRITE: /* write */ 4648 case OP_WRITE: /* write */
… …
4797 SCHEME_V->gc_verbose = (a != S_F); 4793 SCHEME_V->gc_verbose = (a != S_F);
4798 s_retbool (was); 4794 s_retbool (was);
4799 } 4795 }
4800 4796
4801 case OP_NEWSEGMENT: /* new-segment */ 4797 case OP_NEWSEGMENT: /* new-segment */
4798#if 0
4802 if (!is_pair (args) || !is_number (a)) 4799 if (!is_pair (args) || !is_number (a))
4803 Error_0 ("new-segment: argument must be a number"); 4800 Error_0 ("new-segment: argument must be a number");
4804 4801#endif
4805 alloc_cellseg (SCHEME_A_ ivalue (a)); 4802 s_retbool (alloc_cellseg (SCHEME_A));
4806
4807 s_return (S_T);
4808 4803
4809 case OP_OBLIST: /* oblist */ 4804 case OP_OBLIST: /* oblist */
4810 s_return (oblist_all_symbols (SCHEME_A)); 4805 s_return (oblist_all_symbols (SCHEME_A));
4811 4806
4812#if USE_PORTS 4807#if USE_PORTS
… …
4882 s_return (p == NIL ? S_F : p); 4877 s_return (p == NIL ? S_F : p);
4883 } 4878 }
4884 4879
4885 case OP_GET_OUTSTRING: /* get-output-string */ 4880 case OP_GET_OUTSTRING: /* get-output-string */
4886 { 4881 {
4887 port *p; 4882 port *p = port (a);
4888 4883
4889 if ((p = a->object.port)->kind & port_string) 4884 if (p->kind & port_string)
4890 { 4885 {
4891 off_t size; 4886 off_t size;
4892 char *str; 4887 char *str;
4893 4888
4894 size = p->rep.string.curr - p->rep.string.start + 1; 4889 size = p->rep.string.curr - p->rep.string.start + 1;
… …
4999 int res; 4994 int res;
5000 4995
5001 if (is_pair (args)) 4996 if (is_pair (args))
5002 p = car (args); 4997 p = car (args);
5003 4998
5004 res = p->object.port->kind & port_string; 4999 res = port (p)->kind & port_string;
5005 5000
5006 s_retbool (res); 5001 s_retbool (res);
5007 } 5002 }
5008 5003
5009 case OP_SET_INPORT: /* set-input-port */ 5004 case OP_SET_INPORT: /* set-input-port */
… …
5699 SCHEME_V->save_inport = NIL; 5694 SCHEME_V->save_inport = NIL;
5700 SCHEME_V->loadport = NIL; 5695 SCHEME_V->loadport = NIL;
5701 SCHEME_V->nesting = 0; 5696 SCHEME_V->nesting = 0;
5702 SCHEME_V->interactive_repl = 0; 5697 SCHEME_V->interactive_repl = 0;
5703 5698
5704 if (alloc_cellseg (SCHEME_A_ FIRST_CELLSEGS) != FIRST_CELLSEGS) 5699 if (!alloc_cellseg (SCHEME_A))
5705 { 5700 {
5706#if USE_ERROR_CHECKING 5701#if USE_ERROR_CHECKING
5707 SCHEME_V->no_memory = 1; 5702 SCHEME_V->no_memory = 1;
5708 return 0; 5703 return 0;
5709#endif 5704#endif

Diff Legend

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