diff --git a/GNUmakefile b/GNUmakefile
index 7f320ed7..413f4804 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -180,6 +180,9 @@ mini-mes: scaffold/mini-mes.c
guile-mini-mes: module/language/c99/compiler.mes # and others...
guile-mini-mes: mini-mes.h mini-mes.i mini-mes.environment.i mini-mes.symbols.i
guile-mini-mes: gc.c mini-gc.h mini-gc.i mini-gc.environment.i
+guile-mini-mes: lib.c mini-lib.h mini-lib.i mini-lib.environment.i
+guile-mini-mes: math.c mini-math.h mini-math.i mini-math.environment.i
+guile-mini-mes: posix.c mini-posix.h mini-posix.i mini-posix.environment.i
guile-mini-mes: vector.c mini-vector.h mini-vector.i mini-vector.environment.i
guile-mini-mes: mlibc.c mstart.c
guile-mini-mes: GNUmakefile
diff --git a/lib.c b/lib.c
index ec4c4904..67747db3 100644
--- a/lib.c
+++ b/lib.c
@@ -18,31 +18,63 @@
* along with Mes. If not, see .
*/
-//MINI_MES
-// SCM
-// length (SCM x)
-// {
-// int n = 0;
-// while (x != cell_nil)
-// {
-// n++;
-// if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
-// x = cdr (x);
-// }
-// return MAKE_NUMBER (n);
-// }
-
-SCM fdisplay_ (SCM,FILE*);
-
int g_depth;
+#if _POSIX_SOURCE
+
+char const*
+itoa (int x)
+{
+ static char buf[10];
+ char *p = buf+9;
+ *p-- = 0;
+
+ int sign = x < 0;
+ if (sign)
+ x = -x;
+
+ do
+ {
+ *p-- = '0' + (x % 10);
+ x = x / 10;
+ } while (x);
+
+ if (sign)
+ *p-- = '-';
+
+ return p+1;
+}
+
+// from mlib.c
+#define fputs fdputs
+int
+fdputs (char const* s, int fd)
+{
+ int i = strlen (s);
+ write (fd, s, i);
+ return 0;
+}
+
+#ifdef putc
+#undef putc
+#endif
+#define putc fdputc
+int
+fdputc (int c, int fd)
+{
+ write (fd, (char*)&c, 1);
+ return 0;
+}
+#endif
+
+SCM fdisplay_ (SCM, int);
SCM
-display_helper (SCM x, int cont, char* sep, FILE *fd)
+display_helper (SCM x, int cont, char* sep, int fd)
{
fputs (sep, fd);
if (g_depth == 0) return cell_unspecified;
g_depth = g_depth - 1;
-
+
switch (TYPE (x))
{
case TCHAR:
@@ -54,7 +86,11 @@ display_helper (SCM x, int cont, char* sep, FILE *fd)
case TFUNCTION:
{
fputs ("#> 8, stdout);
- fputc (g_stack % 256, stdout);
- // See HACKING, simple crafted dump for tiny-mes.c
- if (getenv ("MES_TINY"))
- {
- TYPE (9) = 0x2d2d2d2d;
- CAR (9) = 0x2d2d2d2d;
- CDR (9) = 0x3e3e3e3e;
-
- TYPE (10) = TPAIR;
- CAR (10) = 11;
- CDR (10) = 12;
-
- TYPE (11) = TCHAR;
- CAR (11) = 0x58585858;
- CDR (11) = 65;
-
- TYPE (12) = TPAIR;
- CAR (12) = 13;
- CDR (12) = 1;
-
- TYPE (13) = TCHAR;
- CAR (11) = 0x58585858;
- CDR (13) = 66;
-
- TYPE (14) = 0x3c3c3c3c;
- CAR (14) = 0x2d2d2d2d;
- CDR (14) = 0x2d2d2d2d;
-
- g_free = 15;
- }
- for (int i=0; i= 0 ? g_stdin : open (MODULEDIR "mes/read-0.mes", O_RDONLY);
- if (!g_function) r0 = mes_builtins (r0);
- r2 = read_input_file_env (r0);
- g_stdin = STDIN;
- return r2;
-}
-
-SCM
-bload_env (SCM a) ///((internal))
-{
-#if MES_MINI
- g_stdin = fopen ("module/mes/read-0-32.mo", O_RDONLY);
-#else
- g_stdin = open ("module/mes/read-0.mo", O_RDONLY);
- g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "mes/read-0.mo", O_RDONLY);
-#endif
-
- char *p = (char*)g_cells;
- assert (getchar () == 'M');
- assert (getchar () == 'E');
- assert (getchar () == 'S');
- g_stack = getchar () << 8;
- g_stack += getchar ();
- int c = getchar ();
- while (c != EOF)
- {
- *p++ = c;
- c = getchar ();
- }
- g_free = (p-(char*)g_cells) / sizeof (struct scm);
- gc_peek_frame ();
- g_symbols = r1;
- g_stdin = STDIN;
- r0 = mes_builtins (r0);
- return r2;
-}
-
SCM
xassq (SCM x, SCM a) ///for speed in core only
{
while (a != cell_nil && x != CDAR (a)) a = CDR (a);
return a != cell_nil ? CAR (a) : cell_f;
}
+
+#if _POSIX_SOURCE
+#undef fdputs
+#undef fdputc
+#endif
diff --git a/mes.c b/mes.c
index ce50363e..90110863 100644
--- a/mes.c
+++ b/mes.c
@@ -1081,13 +1081,103 @@ mes_environment () ///((internal))
}
int g_stdin;
-#include "math.c"
#include "posix.c"
+#include "math.c"
#include "lib.c"
#include "reader.c"
#include "gc.c"
#include "vector.c"
+// extra lib
+SCM
+assert_defined (SCM x, SCM e) ///((internal))
+{
+ if (e == cell_undefined) return error (cell_symbol_unbound_variable, x);
+ return e;
+}
+
+SCM
+check_formals (SCM f, SCM formals, SCM args) ///((internal))
+{
+ int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
+ int alen = VALUE (length (args));
+ if (alen != flen && alen != -1 && flen != -1)
+ {
+ char buf[1024];
+ sprintf (buf, "apply: wrong number of arguments; expected: %d, got: %d: ", flen, alen);
+ SCM e = MAKE_STRING (cstring_to_list (buf));
+ return error (cell_symbol_wrong_number_of_args, cons (e, f));
+ }
+ return cell_unspecified;
+}
+
+SCM
+check_apply (SCM f, SCM e) ///((internal))
+{
+ char const* type = 0;
+ if (f == cell_f || f == cell_t) type = "bool";
+ if (f == cell_nil) type = "nil";
+ if (f == cell_unspecified) type = "*unspecified*";
+ if (f == cell_undefined) type = "*undefined*";
+ if (TYPE (f) == TCHAR) type = "char";
+ if (TYPE (f) == TNUMBER) type = "number";
+ if (TYPE (f) == TSTRING) type = "string";
+
+ if (type)
+ {
+ char buf[1024];
+ sprintf (buf, "cannot apply: %s:", type);
+ fprintf (stderr, " [");
+ display_error_ (e);
+ fprintf (stderr, "]\n");
+ SCM e = MAKE_STRING (cstring_to_list (buf));
+ return error (cell_symbol_wrong_type_arg, cons (e, f));
+ }
+ return cell_unspecified;
+}
+
+SCM
+load_env (SCM a) ///((internal))
+{
+ r0 = a;
+ g_stdin = open ("module/mes/read-0.mes", O_RDONLY);
+ g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "mes/read-0.mes", O_RDONLY);
+ if (!g_function) r0 = mes_builtins (r0);
+ r2 = read_input_file_env (r0);
+ g_stdin = STDIN;
+ return r2;
+}
+
+SCM
+bload_env (SCM a) ///((internal))
+{
+#if MES_MINI
+ g_stdin = fopen ("module/mes/read-0-32.mo", O_RDONLY);
+#else
+ g_stdin = open ("module/mes/read-0.mo", O_RDONLY);
+ g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "mes/read-0.mo", O_RDONLY);
+#endif
+
+ char *p = (char*)g_cells;
+ assert (getchar () == 'M');
+ assert (getchar () == 'E');
+ assert (getchar () == 'S');
+ g_stack = getchar () << 8;
+ g_stack += getchar ();
+ int c = getchar ();
+ while (c != EOF)
+ {
+ *p++ = c;
+ c = getchar ();
+ }
+ g_free = (p-(char*)g_cells) / sizeof (struct scm);
+ gc_peek_frame ();
+ g_symbols = r1;
+ g_stdin = STDIN;
+ r0 = mes_builtins (r0);
+ return r2;
+}
+
int
main (int argc, char *argv[])
{
diff --git a/posix.c b/posix.c
index c80ed8d8..39abe7a8 100644
--- a/posix.c
+++ b/posix.c
@@ -18,18 +18,13 @@
* along with Mes. If not, see .
*/
-#if 0
-#include
-FILE *g_stdin;
-#else
+int g_stdin;
#if _POSIX_SOURCE
int open (char const *s, int mode);
int read (int fd, void* buf, size_t n);
void write (int fd, char const* s, int n);
-#endif
-int g_stdin;
#define O_RDONLY 0
#define STDIN 0
@@ -65,8 +60,9 @@ getchar ()
return i;
}
+#define ungetc fdungetc
int
-fd_ungetc (int c, int fd)
+fdungetc (int c, int fd)
{
assert (ungetc_char < 2);
ungetc_buf[++ungetc_char] = c;
@@ -77,7 +73,7 @@ fd_ungetc (int c, int fd)
int
ungetchar (int c)
{
- return fd_ungetc (c, g_stdin);
+ return ungetc (c, g_stdin);
}
int
@@ -114,7 +110,8 @@ write_byte (SCM x) ///((arity . n))
SCM p = cdr (x);
int fd = 1;
if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p));
-#if _POSIX_SOURCE
+#if 0
+ //_POSIX_SOURCE
FILE *f = fd == 1 ? stdout : stderr;
fputc (VALUE (c), f);
#else
@@ -127,11 +124,13 @@ write_byte (SCM x) ///((arity . n))
return c;
}
+char string_to_cstring_buf[1024];
char const*
string_to_cstring (SCM s)
{
- static char buf[1024];
- char *p = buf;
+ //static char buf[1024];
+ //char *p = buf;
+ char *p = string_to_cstring_buf;
s = STRING(s);
while (s != cell_nil)
{
@@ -139,14 +138,19 @@ string_to_cstring (SCM s)
s = cdr (s);
}
*p = 0;
- return buf;
+ //return buf;
+ return string_to_cstring_buf;
}
SCM
getenv_ (SCM s) ///((name . "getenv"))
{
+#if _POSIX_SOURCE
char *p = getenv (string_to_cstring (s));
return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
+#else
+ return cell_t;
+#endif
}
SCM
@@ -164,18 +168,20 @@ current_input_port ()
SCM
set_current_input_port (SCM port)
{
- g_stdin = VALUE (port);
+ g_stdin = VALUE (port) ? VALUE (port) : STDIN;
return current_input_port ();
}
SCM
force_output (SCM p) ///((arity . n))
{
+#if 0
int fd = 1;
if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p));
#if _POSIX_SOURCE
FILE *f = fd == 1 ? stdout : stderr;
fflush (f);
+#endif
#endif
return cell_unspecified;
}
diff --git a/reader.c b/reader.c
index ee09e365..0e8b8ea0 100644
--- a/reader.c
+++ b/reader.c
@@ -18,6 +18,12 @@
* along with Mes. If not, see .
*/
+#if _POSIX_SOURCE
+#undef fputs
+#undef fdputs
+#undef fdputc
+#endif
+
SCM
___end_of_mes___ ()
{
@@ -112,3 +118,55 @@ lookup_ (SCM s, SCM a)
return lookup_symbol_ (s);
}
+
+//FILE *g_stdin;
+int
+dump ()
+{
+ fputs ("program r2=", stderr);
+ display_error_ (r2);
+ fputs ("\n", stderr);
+
+ r1 = g_symbols;
+ gc_push_frame ();
+ gc ();
+ gc_peek_frame ();
+ char *p = (char*)g_cells;
+ fputc ('M', stdout);
+ fputc ('E', stdout);
+ fputc ('S', stdout);
+ fputc (g_stack >> 8, stdout);
+ fputc (g_stack % 256, stdout);
+ // See HACKING, simple crafted dump for tiny-mes.c
+ if (getenv ("MES_TINY"))
+ {
+ TYPE (9) = 0x2d2d2d2d;
+ CAR (9) = 0x2d2d2d2d;
+ CDR (9) = 0x3e3e3e3e;
+
+ TYPE (10) = TPAIR;
+ CAR (10) = 11;
+ CDR (10) = 12;
+
+ TYPE (11) = TCHAR;
+ CAR (11) = 0x58585858;
+ CDR (11) = 65;
+
+ TYPE (12) = TPAIR;
+ CAR (12) = 13;
+ CDR (12) = 1;
+
+ TYPE (13) = TCHAR;
+ CAR (11) = 0x58585858;
+ CDR (13) = 66;
+
+ TYPE (14) = 0x3c3c3c3c;
+ CAR (14) = 0x2d2d2d2d;
+ CDR (14) = 0x2d2d2d2d;
+
+ g_free = 15;
+ }
+ for (int i=0; i") (arity . n))
-{
- int n = INT_MAX;
- while (x != cell_nil)
- {
- assert (TYPE (car (x)) == TNUMBER);
- if (VALUE (car (x)) >= n) return cell_f;
- n = VALUE (car (x));
- x = cdr (x);
- }
- return cell_t;
-}
-
-SCM
-less_p (SCM x) ///((name . "<") (arity . n))
-{
- int n = INT_MIN;
- while (x != cell_nil)
- {
- assert (TYPE (car (x)) == TNUMBER);
- if (VALUE (car (x)) <= n) return cell_f;
- n = VALUE (car (x));
- x = cdr (x);
- }
- return cell_t;
-}
-
-SCM
-is_p (SCM x) ///((name . "=") (arity . n))
-{
- if (x == cell_nil) return cell_t;
- assert (TYPE (car (x)) == TNUMBER);
- int n = VALUE (car (x));
- x = cdr (x);
- while (x != cell_nil)
- {
- if (VALUE (car (x)) != n) return cell_f;
- x = cdr (x);
- }
- return cell_t;
-}
-
-SCM
-minus (SCM x) ///((name . "-") (arity . n))
-{
- SCM a = car (x);
- assert (TYPE (a) == TNUMBER);
- int n = VALUE (a);
- x = cdr (x);
- if (x == cell_nil)
- n = -n;
- while (x != cell_nil)
- {
- assert (TYPE (car (x)) == TNUMBER);
- n -= VALUE (car (x));
- x = cdr (x);
- }
- return MAKE_NUMBER (n);
-}
-
-SCM
-plus (SCM x) ///((name . "+") (arity . n))
-{
- int n = 0;
- while (x != cell_nil)
- {
- assert (TYPE (car (x)) == TNUMBER);
- n += VALUE (car (x));
- x = cdr (x);
- }
- return MAKE_NUMBER (n);
-}
-
-SCM
-divide (SCM x) ///((name . "/") (arity . n))
-{
- int n = 1;
- if (x != cell_nil) {
- assert (TYPE (car (x)) == TNUMBER);
- n = VALUE (car (x));
- x = cdr (x);
- }
- while (x != cell_nil)
- {
- assert (TYPE (car (x)) == TNUMBER);
- n /= VALUE (car (x));
- x = cdr (x);
- }
- return MAKE_NUMBER (n);
-}
-
-SCM
-modulo (SCM a, SCM b)
-{
- assert (TYPE (a) == TNUMBER);
- assert (TYPE (b) == TNUMBER);
- int x = VALUE (a);
- while (x < 0) x += VALUE (b);
- return MAKE_NUMBER (x % VALUE (b));
-}
-
-SCM
-multiply (SCM x) ///((name . "*") (arity . n))
-{
- int n = 1;
- while (x != cell_nil)
- {
- assert (TYPE (car (x)) == TNUMBER);
- n *= VALUE (car (x));
- x = cdr (x);
- }
- return MAKE_NUMBER (n);
-}
-
-SCM
-logior (SCM x) ///((arity . n))
-{
- int n = 0;
- while (x != cell_nil)
- {
- assert (TYPE (car (x)) == TNUMBER);
- n |= VALUE (car (x));
- x = cdr (x);
- }
- return MAKE_NUMBER (n);
-}
-
-SCM
-ash (SCM n, SCM count)
-{
- assert (TYPE (n) == TNUMBER);
- assert (TYPE (count) == TNUMBER);
- int cn = VALUE (n);
- int ccount = VALUE (count);
- return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
-}
-
-// Lib [rest of]
-
-int g_depth;
-
-SCM
-display_helper (SCM x, int cont, char* sep, int fd)
-{
- fputs (sep, fd);
- if (g_depth == 0) return cell_unspecified;
- g_depth = g_depth - 1;
-
- switch (TYPE (x))
- {
- case TCHAR:
- {
- fputs ("#\\", fd);
- putc (VALUE (x), fd);
- break;
- }
- case TFUNCTION:
- {
- fputs ("#", fd);
- break;
- }
- case TMACRO:
- {
- fputs ("#", fd);
- break;
- }
- case TNUMBER:
- {
- fputs (itoa (VALUE (x)), fd);
- break;
- }
- case TPAIR:
- {
- if (!cont) fputs ("(", fd);
- if (x && x != cell_nil) fdisplay_ (CAR (x), fd);
- if (CDR (x) && TYPE (CDR (x)) == TPAIR)
- display_helper (CDR (x), 1, " ", fd);
- else if (CDR (x) && CDR (x) != cell_nil)
- {
- if (TYPE (CDR (x)) != TPAIR)
- fputs (" . ", fd);
- fdisplay_ (CDR (x), fd);
- }
- if (!cont) fputs (")", fd);
- break;
- }
- case TSPECIAL:
-#if __NYACC__
- // FIXME
- //{}
- {
- SCM t = CAR (x);
- while (t && t != cell_nil)
- {
- putc (VALUE (CAR (t)), fd);
- t = CDR (t);
- }
- break;
- }
-#endif
- case TSTRING:
-#if __NYACC__
- // FIXME
- {
- SCM t = CAR (x);
- while (t && t != cell_nil)
- {
- putc (VALUE (CAR (t)), fd);
- t = CDR (t);
- }
- break;
- }
-#endif
- case TSYMBOL:
- {
- SCM t = CAR (x);
- while (t && t != cell_nil)
- {
- putc (VALUE (CAR (t)), fd);
- t = CDR (t);
- }
- break;
- }
- default:
- {
- fputs ("<", fd);
- fputs (itoa (TYPE (x)), fd);
- fputs (":", fd);
- fputs (itoa (x), fd);
- fputs (">", fd);
- break;
- }
- }
- return 0;
-}
-
-SCM
-display_ (SCM x)
-{
- g_depth = 5;
- return display_helper (x, 0, "", STDOUT);
-}
-
-SCM
-display_error_ (SCM x)
-{
- g_depth = 5;
- return display_helper (x, 0, "", STDERR);
-}
-
-SCM
-fdisplay_ (SCM x, int fd) ///((internal))
-{
- g_depth = 5;
- return display_helper (x, 0, "", fd);
-}
-
-SCM
-exit_ (SCM x) ///((name . "exit"))
-{
- assert (TYPE (x) == TNUMBER);
- exit (VALUE (x));
-}
-
-SCM
-xassq (SCM x, SCM a) ///for speed in core only
-{
- while (a != cell_nil && x != CDAR (a)) a = CDR (a);
- return a != cell_nil ? CAR (a) : cell_f;
-}
+#include "posix.c"
+#include "math.c"
+#include "lib.c"
// Jam Collector
SCM g_symbol_max;
@@ -1552,19 +1157,19 @@ mes_builtins (SCM a) ///((internal))
#include "mini-mes.i"
// Do not sort: Order of these includes define builtins
-// #include "lib.i"
-// #include "math.i"
-// #include "posix.i"
+#include "mini-posix.i"
+#include "mini-math.i"
+#include "mini-lib.i"
#include "mini-vector.i"
#include "mini-gc.i"
-// #include "reader.i"
+// #include "mini-reader.i"
#include "mini-gc.environment.i"
-// #include "lib.environment.i"
-// #include "math.environment.i"
+#include "mini-lib.environment.i"
+#include "mini-math.environment.i"
#include "mini-mes.environment.i"
-// #include "posix.environment.i"
-// #include "reader.environment.i"
+#include "mini-posix.environment.i"
+// #include "mini-reader.environment.i"
#include "mini-vector.environment.i"
return a;
@@ -1631,10 +1236,6 @@ bload_env (SCM a) ///((internal))
return r2;
}
-// #include "math.c"
-// #include "posix.c"
-// #include "lib.c"
-// #include "reader.c"
#include "vector.c"
#include "gc.c"