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.51 by root, Tue Dec 1 01:54:27 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>
… …
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{
… …
254static num num_op (enum num_op op, num a, num b); 250static num num_op (enum num_op op, num a, num b);
255static num num_intdiv (num a, num b); 251static num num_intdiv (num a, num b);
256static num num_rem (num a, num b); 252static num num_rem (num a, num b);
257static num num_mod (num a, num b); 253static num num_mod (num a, num b);
258 254
259#if USE_MATH
260static double round_per_R5RS (double x);
261#endif
262static int is_zero_rvalue (RVALUE x); 255static int is_zero_rvalue (RVALUE x);
263 256
264static num num_zero; 257static num num_zero;
265static num num_one; 258static num num_one;
266 259
… …
876 } 869 }
877 870
878 return ret; 871 return ret;
879} 872}
880 873
881#if USE_MATH
882
883/* Round to nearest. Round to even if midway */
884static double
885round_per_R5RS (double x)
886{
887 double fl = floor (x);
888 double ce = ceil (x);
889 double dfl = x - fl;
890 double dce = ce - x;
891
892 if (dfl > dce)
893 return ce;
894 else if (dfl < dce)
895 return fl;
896 else
897 {
898 if (fmod (fl, 2) == 0) /* I imagine this holds */
899 return fl;
900 else
901 return ce;
902 }
903}
904#endif
905
906static int 874static int
907is_zero_rvalue (RVALUE x) 875is_zero_rvalue (RVALUE x)
908{ 876{
909 return x == 0; 877 return x == 0;
910#if 0 878#if 0
… …
1056static void 1024static void
1057check_cell_alloced (pointer p, int expect_alloced) 1025check_cell_alloced (pointer p, int expect_alloced)
1058{ 1026{
1059 /* 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. */
1060 if (typeflag (p) & !expect_alloced) 1028 if (typeflag (p) & !expect_alloced)
1061 xwrstr ("Cell is already allocated!\n"); 1029 putstr (SCHEME_A_ "Cell is already allocated!\n");
1062 1030
1063 if (!(typeflag (p)) & expect_alloced) 1031 if (!(typeflag (p)) & expect_alloced)
1064 xwrstr ("Cell is not allocated!\n"); 1032 putstr (SCHEME_A_ "Cell is not allocated!\n");
1065} 1033}
1066 1034
1067static void 1035static void
1068check_range_alloced (pointer p, int n, int expect_alloced) 1036check_range_alloced (pointer p, int n, int expect_alloced)
1069{ 1037{
… …
1672 clrmark (NIL); 1640 clrmark (NIL);
1673 SCHEME_V->fcells = 0; 1641 SCHEME_V->fcells = 0;
1674 SCHEME_V->free_cell = NIL; 1642 SCHEME_V->free_cell = NIL;
1675 1643
1676 if (SCHEME_V->gc_verbose) 1644 if (SCHEME_V->gc_verbose)
1677 xwrstr ("freeing..."); 1645 putstr (SCHEME_A_ "freeing...");
1678 1646
1679 uint32_t total = 0; 1647 uint32_t total = 0;
1680 1648
1681 /* Here we scan the cells to build the free-list. */ 1649 /* Here we scan the cells to build the free-list. */
1682 for (i = SCHEME_V->last_cell_seg; i >= 0; i--) 1650 for (i = SCHEME_V->last_cell_seg; i >= 0; i--)
… …
1708 } 1676 }
1709 } 1677 }
1710 1678
1711 if (SCHEME_V->gc_verbose) 1679 if (SCHEME_V->gc_verbose)
1712 { 1680 {
1713 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");
1714 } 1682 }
1715} 1683}
1716 1684
1717static void 1685static void
1718finalize_cell (SCHEME_P_ pointer a) 1686finalize_cell (SCHEME_P_ pointer a)
… …
2091 *pt->rep.string.curr++ = *s; 2059 *pt->rep.string.curr++ = *s;
2092 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))
2093 *pt->rep.string.curr++ = *s; 2061 *pt->rep.string.curr++ = *s;
2094 2062
2095#else 2063#else
2096 xwrstr (s); 2064 write (pt->rep.stdio.file, s, strlen (s));
2097#endif 2065#endif
2098} 2066}
2099 2067
2100static void 2068static void
2101putchars (SCHEME_P_ const char *s, int len) 2069putchars (SCHEME_P_ const char *s, int len)
… …
3341 s_return (S_T); 3309 s_return (S_T);
3342#endif 3310#endif
3343 case OP_LOAD: /* load */ 3311 case OP_LOAD: /* load */
3344 if (file_interactive (SCHEME_A)) 3312 if (file_interactive (SCHEME_A))
3345 { 3313 {
3346 xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n"); 3314 putstr (SCHEME_A_ "Loading "); putstr (SCHEME_A_ strvalue (car (args))); putstr (SCHEME_A_ "\n");
3347 //D fprintf (port (SCHEME_V->outport)->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)));
3348 } 3316 }
3349 3317
3350 if (!file_push (SCHEME_A_ strvalue (car (args)))) 3318 if (!file_push (SCHEME_A_ strvalue (car (args))))
3351 Error_1 ("unable to open", car (args)); 3319 Error_1 ("unable to open", car (args));
… …
4095 s_return (mk_real (SCHEME_A_ result)); 4063 s_return (mk_real (SCHEME_A_ result));
4096 else 4064 else
4097 s_return (mk_integer (SCHEME_A_ result)); 4065 s_return (mk_integer (SCHEME_A_ result));
4098 } 4066 }
4099 4067
4100 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))));
4101 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))));
4102
4103 case OP_TRUNCATE:
4104 {
4105 RVALUE n = rvalue (x);
4106 s_return (mk_real (SCHEME_A_ n > 0 ? floor (n) : ceil (n)));
4107 }
4108
4109 case OP_ROUND:
4110 if (is_integer (x))
4111 s_return (x);
4112
4113 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))));
4114#endif 4072#endif
4115 4073
4116 case OP_ADD: /* + */ 4074 case OP_ADD: /* + */
4117 v = num_zero; 4075 v = num_zero;
4118 4076
… …
5544 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))
5545 return; 5503 return;
5546 5504
5547 if (SCHEME_V->no_memory && USE_ERROR_CHECKING) 5505 if (SCHEME_V->no_memory && USE_ERROR_CHECKING)
5548 { 5506 {
5549 xwrstr ("No memory!\n"); 5507 putstr (SCHEME_A_ "No memory!\n");
5550 return; 5508 return;
5551 } 5509 }
5552 } 5510 }
5553} 5511}
5554 5512
… …
6038 int isfile = 1; 5996 int isfile = 1;
6039 system ("ps v $PPID");//D 5997 system ("ps v $PPID");//D
6040 5998
6041 if (argc == 2 && strcmp (argv[1], "-?") == 0) 5999 if (argc == 2 && strcmp (argv[1], "-?") == 0)
6042 { 6000 {
6043 xwrstr ("Usage: tinyscheme -?\n"); 6001 putstr (SCHEME_A_ "Usage: tinyscheme -?\n");
6044 xwrstr ("or: tinyscheme [<file1> <file2> ...]\n"); 6002 putstr (SCHEME_A_ "or: tinyscheme [<file1> <file2> ...]\n");
6045 xwrstr ("followed by\n"); 6003 putstr (SCHEME_A_ "followed by\n");
6046 xwrstr (" -1 <file> [<arg1> <arg2> ...]\n"); 6004 putstr (SCHEME_A_ " -1 <file> [<arg1> <arg2> ...]\n");
6047 xwrstr (" -c <Scheme commands> [<arg1> <arg2> ...]\n"); 6005 putstr (SCHEME_A_ " -c <Scheme commands> [<arg1> <arg2> ...]\n");
6048 xwrstr ("assuming that the executable is named tinyscheme.\n"); 6006 putstr (SCHEME_A_ "assuming that the executable is named tinyscheme.\n");
6049 xwrstr ("Use - as filename for stdin.\n"); 6007 putstr (SCHEME_A_ "Use - as filename for stdin.\n");
6050 return 1; 6008 return 1;
6051 } 6009 }
6052 6010
6053 if (!scheme_init (SCHEME_A)) 6011 if (!scheme_init (SCHEME_A))
6054 { 6012 {
6055 xwrstr ("Could not initialize!\n"); 6013 putstr (SCHEME_A_ "Could not initialize!\n");
6056 return 2; 6014 return 2;
6057 } 6015 }
6058 6016
6059# if USE_PORTS 6017# if USE_PORTS
6060 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO); 6018 scheme_set_input_port_file (SCHEME_A_ STDIN_FILENO);
… …
6105 fin = open (file_name, O_RDONLY); 6063 fin = open (file_name, O_RDONLY);
6106#endif 6064#endif
6107 6065
6108 if (isfile && fin < 0) 6066 if (isfile && fin < 0)
6109 { 6067 {
6110 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");
6111 } 6069 }
6112 else 6070 else
6113 { 6071 {
6114 if (isfile) 6072 if (isfile)
6115 scheme_load_named_file (SCHEME_A_ fin, file_name); 6073 scheme_load_named_file (SCHEME_A_ fin, file_name);
… …
6119#if USE_PORTS 6077#if USE_PORTS
6120 if (!isfile || fin != STDIN_FILENO) 6078 if (!isfile || fin != STDIN_FILENO)
6121 { 6079 {
6122 if (SCHEME_V->retcode != 0) 6080 if (SCHEME_V->retcode != 0)
6123 { 6081 {
6124 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");
6125 } 6083 }
6126 6084
6127 if (isfile) 6085 if (isfile)
6128 close (fin); 6086 close (fin);
6129 } 6087 }

Diff Legend

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