mescc: Mini-mes (gcc-compiled) runs read-0.mes.

* module/language/c99/compiler.mes (expr->accu): Add mul.
  (test->jump->info): Add le, ge.
  (ast->info): Support int and char* initialization at top level.
* module/mes/as-i386.mes (i386:accu*base, i386:Xjump-cz,
  i386:Xjump-ncz): New function.
* module/mes/as-i386.scm: Export them.
* doc/examples/t.c (test): Test them.
* module/mes/libc.mes (ungetc): New function.
  (getchar): Support it.
  (assert_fail, isdigit): New functions.
  (libc): Export them.
* module/mes/mini-0.mes: Load full reader.
* mlibc.c (ungetc): New function.
  (getchar): Support it.
  (assert_fail, isdigit): New functions.
* mes.c (list length error lookup_ getchar ungetchar peekchar
  peek_byte read_byte unread_byte greater_p less_p): Move functions
  needed to run read-0.mes into core.
* doc/examples/mini-mes.c: Likewise.
* lib.c (length, error): Comment-out.
* math.c (greater_p, less_p): Comment-out.
* posix.c: (getchar, ungetchar, peekchar, peek_byte, read_byte,
  unread_byte): Comment-out.
* reader.c (lookup_): Comment-out.

lib.c

@@ -25,24 +25,19 @@ xassq (SCM x, SCM a) ///for speed in core only
   return a != cell_nil ? CAR (a) : cell_f;
 }
 
-SCM
+//MINI_MES
-length (SCM x)
+// SCM
-{
+// length (SCM x)
-  int n = 0;
+// {
-  while (x != cell_nil)
+//   int n = 0;
-    {
+//   while (x != cell_nil)
-      n++;
+//     {
-      if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
+//       n++;
-      x = cdr (x);
+//       if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
-    }
+//       x = cdr (x);
-  return MAKE_NUMBER (n);
+//     }
-}
+//   return MAKE_NUMBER (n);
-
+// }
-SCM
-list (SCM x) ///((arity . n))
-{
-  return x;
-}
 
 SCM
 exit_ (SCM x) ///((name . "exit"))
@@ -75,24 +70,24 @@ append (SCM x) ///((arity . n))
 //   return buf;
 // }
 
-SCM
+// SCM
-error (SCM key, SCM x)
+// error (SCM key, SCM x)
-{
+// {
-  SCM throw;
+//   SCM throw;
-  if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
+//   if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
-    return apply (throw, cons (key, cons (x, cell_nil)), r0);
+//     return apply (throw, cons (key, cons (x, cell_nil)), r0);
-  assert (!"error");
+//   assert (!"error");
-}
+// }
 
 SCM
-assert_defined (SCM x, SCM e)
+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)
+check_formals (SCM f, SCM formals, SCM args) ///((internal))
 {
   int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
   int alen = VALUE (length (args));
@@ -154,7 +149,7 @@ itoa (int x)
   return p+1;
 }
 
-FILE *g_stdin;
+//FILE *g_stdin;
 int
 dump ()
 {

math.c

@@ -18,33 +18,34 @@
  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  */
 
-SCM
+//MINI_MES
-greater_p (SCM x) ///((name . ">") (arity . n))
+// SCM
-{
+// greater_p (SCM x) ///((name . ">") (arity . n))
-  int n = INT_MAX;
+// {
-  while (x != cell_nil)
+//   int n = INT_MAX;
-    {
+//   while (x != cell_nil)
-      assert (TYPE (car (x)) == TNUMBER);
+//     {
-      if (VALUE (car (x)) >= n) return cell_f;
+//       assert (TYPE (car (x)) == TNUMBER);
-      n = VALUE (car (x));
+//       if (VALUE (car (x)) >= n) return cell_f;
-      x = cdr (x);
+//       n = VALUE (car (x));
-    }
+//       x = cdr (x);
-  return cell_t;
+//     }
-}
+//   return cell_t;
+// }
 
-SCM
+// SCM
-less_p (SCM x) ///((name . "<") (arity . n))
+// less_p (SCM x) ///((name . "<") (arity . n))
-{
+// {
-  int n = INT_MIN;
+//   int n = INT_MIN;
-  while (x != cell_nil)
+//   while (x != cell_nil)
-    {
+//     {
-      assert (TYPE (car (x)) == TNUMBER);
+//       assert (TYPE (car (x)) == TNUMBER);
-      if (VALUE (car (x)) <= n) return cell_f;
+//       if (VALUE (car (x)) <= n) return cell_f;
-      n = VALUE (car (x));
+//       n = VALUE (car (x));
-      x = cdr (x);
+//       x = cdr (x);
-    }
+//     }
-  return cell_t;
+//   return cell_t;
-}
+// }
 
 SCM
 is_p (SCM x) ///((name . "=") (arity . n))

mes.c

@@ -220,6 +220,9 @@ SCM r3 = 0; // continuation
 #define MAKE_STRING(x) make_cell (tmp_num_ (TSTRING), x, 0)
 
 SCM vm_call (function0_t f, SCM p1, SCM a);
+char const* itoa(int);
+
+#define eputs(s) fputs(s, stderr)
 
 SCM
 tmp_num_ (int x)
@@ -284,6 +287,12 @@ cdr (SCM x)
   return CDR (x);
 }
 
+SCM
+list (SCM x) ///((arity . n))
+{
+  return x;
+}
+
 SCM
 null_p (SCM x)
 {
@@ -330,6 +339,29 @@ cdr_ (SCM x)
           || TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
 }
 
+// MIMI_MES lib.c?
+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
+error (SCM key, SCM x)
+{
+  SCM throw;
+  if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
+    return apply (throw, cons (key, cons (x, cell_nil)), r0);
+  assert (!"error");
+}
+
 SCM
 append2 (SCM x, SCM y)
 {
@@ -358,6 +390,12 @@ call (SCM fn, SCM x)
   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
       && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
+#if 0
+  eputs ("call: ");
+  if (FUNCTION (fn).name) eputs (FUNCTION (fn).name);
+  else eputs (itoa (CDR (fn)));
+  eputs ("\n");
+#endif
   switch (FUNCTION (fn).arity)
     {
     case 0: return FUNCTION (fn).function0 ();
@@ -429,6 +467,18 @@ lookup_macro (SCM x, SCM a)
 {
   if (TYPE (x) != TSYMBOL) return cell_f;
   SCM m = assq_ref_env (x, a);
+#if 0
+  if (TYPE (m) == TMACRO)
+    {
+      fputs ("XXmacro: ", stdout);
+      fputs ("[", stdout);
+      fputs (itoa (m), stdout);
+      fputs ("]: ", stdout);
+      display_ (m);
+      fputs ("\n", stdout);
+
+    }
+#endif
   if (TYPE (m) == TMACRO) return MACRO (m);
   return cell_f;
 }
@@ -687,6 +737,14 @@ eval_apply ()
       && (macro = lookup_macro (car (r1), r0)) != cell_f)
     {
       r1 = cons (macro, CDR (r1));
+#if 0
+      fputs ("macro: ", stdout);
+      display_ (macro);
+      fputs ("\n", stdout);
+      fputs ("r1: ", stdout);
+      display_ (r1);
+      fputs ("\n", stdout);
+#endif
       goto apply;
     }
   else if (TYPE (r1) == TPAIR
@@ -721,6 +779,11 @@ eval_apply ()
     if (CDR (r1) == cell_nil)
       {
         r1 = car (r1);
+#if 0
+        fputs ("begin: ", stdout);
+        display_ (r1);
+        fputs ("\n", stdout);
+#endif
         goto eval;
       }
     push_cc (CAR (r1), r1, r0, cell_vm_begin2);
@@ -861,6 +924,30 @@ make_symbol (SCM s)
   return x ? x : make_symbol_ (s);
 }
 
+//MINI_MES reader.c
+SCM
+lookup_ (SCM s, SCM a)
+{
+  if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) {
+    SCM p = s;
+    int sign = 1;
+    if (VALUE (car (s)) == '-') {
+      sign = -1;
+      p = cdr (s);
+    }
+    int n = 0;
+    while (p != cell_nil && isdigit (VALUE (car (p)))) {
+      n *= 10;
+      n += VALUE (car (p)) - '0';
+      p = cdr (p);
+    }
+    if (p == cell_nil) return MAKE_NUMBER (n * sign);
+  }
+
+  SCM x = lookup_symbol_ (s);
+  return x ? x : make_symbol_ (s);
+}
+
 SCM
 acons (SCM key, SCM value, SCM alist)
 {
@@ -868,6 +955,46 @@ acons (SCM key, SCM value, SCM alist)
 }
 
 // temp MINI_MES lib
+//posix.c
+FILE *g_stdin;
+int
+getchar ()
+{
+  return getc (g_stdin);
+}
+
+int
+ungetchar (int c)
+{
+  return ungetc (c, g_stdin);
+}
+
+int
+peekchar ()
+{
+  int c = getchar ();
+  ungetchar (c);
+  return c;
+}
+
+SCM
+peek_byte ()
+{
+  return MAKE_NUMBER (peekchar ());
+}
+
+SCM
+read_byte ()
+{
+  return MAKE_NUMBER (getchar ());
+}
+
+SCM
+unread_byte (SCM i)
+{
+  ungetchar (VALUE (i));
+  return i;
+}
 
 SCM
 write_byte (SCM x) ///((arity . n))
@@ -897,10 +1024,6 @@ string_to_cstring (SCM s)
   return buf;
 }
 
-#if __GNUC__
-char const* itoa(int);
-#endif
-
 SCM
 display_ (SCM x)
 {
@@ -909,137 +1032,73 @@ display_ (SCM x)
     {
     case TCHAR:
       {
-        //puts ("<char>\n");
+        //fputs ("<char>\n", stdout);
-        puts ("#\\");
+        fputs ("#\\", stdout);
         putchar (VALUE (x));
         break;
       }
     case TFUNCTION:
       {
-#if __GNUC__
+        fputs ("#<procedure ", stdout);
-        puts ("#<procedure ");
+        ///fputs (FUNCTION (x).name ? FUNCTION (x).name : "?", stdout);
-        puts (FUNCTION (x).name ? FUNCTION (x).name : "?");
+        char *p = "?";
-        puts ("[");
+        if (FUNCTION (x).name != 0)
-        puts (itoa (CDR (x)));
+          p = FUNCTION (x).name;
-        puts ("]>");
+        fputs (p, stdout);
+        fputs ("[", stdout);
+        fputs (itoa (CDR (x)), stdout);
+        fputs ("]>", stdout);
         break;
-#endif
+      }
-        //puts ("<function>\n");
+    case TMACRO:
-        if (VALUE (x) == 0)
+      {
-          puts ("make-cell");
+        fputs ("#<macro ", 1);
-        if (VALUE (x) == 1)
+        display_ (cdr (x));
-          puts ("cons");
+        fputs (">", 1);
-        if (VALUE (x) == 2)
-          puts ("car");
-        if (VALUE (x) == 3)
-          puts ("cdr");
         break;
       }
     case TNUMBER:
       {
-        //puts ("<number>\n");
+        //fputs ("<number>\n", stdout);
-#if __GNUC__
+        fputs (itoa (VALUE (x)), stdout);
-        puts (itoa (VALUE (x)));
-#else
-        int i;
-        i = VALUE (x);
-        i = i + 48;
-        putchar (i);
-#endif
         break;
       }
     case TPAIR:
       {
-        //puts ("<pair>\n");
+        //fputs ("<pair>\n", stdout);
-        //if (cont != cell_f) puts "(");
+        //if (cont != cell_f) fputs ("(", stdout);
-        puts ("(");
+        fputs ("(", stdout);
         if (x && x != cell_nil) display_ (CAR (x));
         if (CDR (x) && CDR (x) != cell_nil)
           {
-#if __GNUC__
             if (TYPE (CDR (x)) != TPAIR)
-              puts (" . ");
+              fputs (" . ", stdout);
-#else
-            int c;
-            c = CDR (x);
-            c = TYPE (c);
-            if (c != TPAIR)
-              puts (" . ");
-#endif
             display_ (CDR (x));
           }
-        //if (cont != cell_f) puts (")");
+        //if (cont != cell_f) fputs (")", stdout);
-        puts (")");
+        fputs (")", stdout);
         break;
       }
     case TSPECIAL:
-      {
+    case TSTRING:
-        switch (x)
-          {
-          case 1: {puts ("()"); break;}
-          case 2: {puts ("#f"); break;}
-          case 3: {puts ("#t"); break;}
-          default:
-            {
-#if __GNUC__
-        puts ("<x:");
-        puts (itoa (x));
-        puts (">");
-#else
-        puts ("<x>");
-#endif
-            }
-          }
-        break;
-      }
     case TSYMBOL:
       {
-#if 0
-        switch (x)
-          {
-          case 11: {puts (" . "); break;}
-          case 12: {puts ("lambda"); break;}
-          case 13: {puts ("begin"); break;}
-          case 14: {puts ("if"); break;}
-          case 15: {puts ("quote"); break;}
-          case 37: {puts ("car"); break;}
-          case 38: {puts ("cdr"); break;}
-          case 39: {puts ("null?"); break;}
-          case 40: {puts ("eq?"); break;}
-          case 41: {puts ("cons"); break;}
-          default:
-            {
-#if __GNUC__
-        puts ("<s:");
-        puts (itoa (x));
-        puts (">");
-#else
-        puts ("<s>");
-#endif
-            }
-          }
-        break;
-#else
         SCM t = CAR (x);
-        while (t != cell_nil)
+        while (t && t != cell_nil)
           {
             putchar (VALUE (CAR (t)));
             t = CDR (t);
           }
-#endif
+        break;
       }
     default:
       {
-        //puts ("<default>\n");
+        //fputs ("<default>\n", stdout);
-#if __GNUC__
+        fputs ("<", stdout);
-        puts ("<");
+        fputs (itoa (TYPE (x)), stdout);
-        puts (itoa (TYPE (x)));
+        fputs (":", stdout);
-        puts (":");
+        fputs (itoa (x), stdout);
-        puts (itoa (x));
+        fputs (">", stdout);
-        puts (">");
-#else
-        puts ("_");
-#endif
         break;
       }
     }
@@ -1063,6 +1122,36 @@ stderr_ (SCM x)
   return cell_unspecified;
 }
 
+//math.c
+SCM
+greater_p (SCM x) ///((name . ">") (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;
+}
+
+// MINI_MES+
 SCM
 make_vector (SCM n)
 {
@@ -1393,8 +1482,9 @@ main (int argc, char *argv[])
   push_cc (r2, cell_unspecified, r0, cell_unspecified);
   r3 = cell_vm_begin;
   r1 = eval_apply ();
-  stderr_ (r1);
+  ///stderr_ (r1);
-  fputs ("", stderr);
+  display_ (r1);
+  fputs ("", stdout);
   gc (g_stack);
 #if __GNUC__
   if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free);

mlibc.c

@@ -40,6 +40,17 @@ exit (int code)
   exit (0);
 }
 
+void
+assert_fail (char* s)
+{
+  eputs ("assert fail: ");
+  eputs (s);
+  eputs ("\n");
+  *((int*)0) = 0;
+}
+
+#define assert(x) ((x) ? (void)0 : assert_fail (#x))
+
 char const*
 getenv (char const* p)
 {
@@ -86,17 +97,36 @@ open (char const *s, int mode)
 int puts (char const*);
 char const* itoa (int);
 
+int ungetc_char = -1;
+
 int
 getchar ()
 {
   char c;
-  int r = read (g_stdin, &c, 1);
+  int i;
-  if (r < 1) return -1;
+  if (ungetc_char == -1)
-  int i = c;
+    {
+      int r = read (g_stdin, &c, 1);
+      if (r < 1) return -1;
+      i = c;
+    }
+  else
+    {
+      i = ungetc_char;
+      ungetc_char = -1;
+    }
   if (i < 0) i += 256;
   return i;
 }
 
+int
+ungetc (int c, int fd)
+{
+  assert (ungetc_char == -1);
+  ungetc_char = c;
+  return c;
+}
+
 void
 write (int fd, char const* s, int n)
 {
@@ -217,14 +247,9 @@ itoa (int x)
   return p+1;
 }
 
-void
+int
-assert_fail (char* s)
+isdigit (char c)
 {
-  eputs ("assert fail: ");
+  return (c>='0') && (c<='9');
-  eputs (s);
-  eputs ("\n");
-  *((int*)0) = 0;
 }
-
-#define assert(x) ((x) ? (void)0 : assert_fail (#x))
 #endif

module/language/c99/compiler.mes

@@ -784,6 +784,17 @@ _)))))
                           (list (lambda (f g ta t d)
                                   (i386:accu%base)))))))
 
+        ((mul ,a ,b)
+         (let* ((empty (clone info #:text '()))
+                (accu ((expr->accu empty) a))
+                (base ((expr->base empty) b)))
+           (clone info #:text
+                  (append text
+                          (.text accu)
+                          (.text base)
+                          (list (lambda (f g ta t d)
+                                  (i386:accu*base)))))))
+
         ;; FIXME: c/p ast->info
         ((eq ,a ,b)
          (let* ((base ((expr->base info) a))
@@ -1058,7 +1069,9 @@ _)))))
                         (jump-text body-length)))))))
   (lambda (o)
     (pmatch o
+      ((le ,a ,b) ((jump i386:Xjump-ncz) o))
       ((lt ,a ,b) ((jump i386:Xjump-nc) o))
+      ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
       ((gt ,a ,b) ((jump i386:Xjump-nc) o))
       ((ne ,a ,b) ((jump i386:Xjump-nz) o))
       ((eq ,a ,b) ((jump i386:Xjump-nz) o))
@@ -1610,6 +1623,21 @@ _)))))
                           (list (lambda (f g ta t d)
                                   (i386:sub-base)))))))
 
+        ((ge ,a ,b)
+         (let* ((base ((expr->base info) a))
+                (empty (clone base #:text '()))
+                (accu ((expr->accu empty) b)))
+           (clone info #:text
+                  (append text
+                          (.text base)
+                          (list (lambda (f g ta t d)
+                                  (i386:push-base)))
+                          (.text accu)
+                          (list (lambda (f g ta t d)
+                                  (i386:pop-base)))
+                          (list (lambda (f g ta t d)
+                                  (i386:sub-base)))))))
+
         ((gt ,a ,b)
          (let* ((base ((expr->base info) a))
                 (empty (clone base #:text '()))
@@ -1642,6 +1670,19 @@ _)))))
                                    (i386:sub-base)
                                    (i386:xor-zf))))))))
 
+        ((le ,a ,b)
+         (let* ((base ((expr->base info) a))
+                (empty (clone base #:text '()))
+                (accu ((expr->accu empty) b)))
+           (clone info #:text
+                  (append text
+                          (.text base)
+                          (list (lambda (f g ta t d)
+                                  (i386:push-base)))
+                          (.text accu)
+                          (list (lambda (f g ta t d)
+                                  (i386:base-sub)))))))
+
         ((lt ,a ,b)
          (let* ((base ((expr->base info) a))
                 (empty (clone base #:text '()))
@@ -1752,13 +1793,14 @@ _)))))
 
         ;; int i = -1;
         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
-         (if (not (.function info)) decl-barf1)
+         (let ((value (- (cstring->number value))))
-         (let* ((locals (add-local locals name type 0))
+           (if (.function info)
-                (info (clone info #:locals locals))
+               (let* ((locals (add-local locals name type 0))
-                (value (- (cstring->number value))))
+                      (info (clone info #:locals locals)))
-           (clone info #:text
+                 (clone info #:text
-                  (append text
+                        (append text
-                          ((value->ident info) name value)))))
+                                ((value->ident info) name value))))
+               (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
 
         ;; int i = argc;
         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
@@ -1784,6 +1826,18 @@ _)))))
                                    (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
                           ((accu->ident info) name)))))
         
+        ;; char *p = 0;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
+         (if (not (.function info)) decl-barf3)
+         (let* ((value (cstring->number value))
+                (locals (add-local locals name type 1))
+                (info (clone info #:locals locals)))
+           (clone info #:text
+                  (append text
+                          (list (lambda (f g ta t d)
+                                  (i386:value->accu value)))
+                          ((accu->ident info) name)))))
+
         ;; char arena[20000];
         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
          (let ((type (ast->type type)))

module/mes/as-i386.mes

@@ -139,6 +139,9 @@
 (define (i386:accu-base)
   `(#x29 #xd0))                         ; sub    %edx,%eax
 
+(define (i386:accu*base)
+  `(#xf7 #xe2))                         ; mul    %edx
+
 (define (i386:accu/base)
   '(#x86 #xd3                           ; mov    %edx,%ebx
     #x31 #xd2                           ; xor    %edx,%edx
@@ -347,7 +350,7 @@
   (when (or (> n #x80) (< n #x-80))
     (format (current-error-port) "JUMP n=~a\n" n)
     barf)
-  `(#x76 ,(if (>= n 0) n (- n 2))))     ; jna <n>
+  `(#x76 ,(if (>= n 0) n (- n 2))))     ; jbe <n>
 
 (define (i386:jump-ncz n)
   (when (or (> n #x80) (< n #x-80))
@@ -365,17 +368,25 @@
   (or n urg:Xjump-nc)
   `(#x0f #x83 ,@(int->bv32 n)))         ; jnc <n>
 
+(define (i386:Xjump-cz n)
+  (or n urg:Xjump-cz)
+  `(#x0f #x86 ,@(int->bv32 n)))         ; jbe <n>
+
+(define (i386:Xjump-ncz n)
+  (or n urg:Xjump-ncz)
+  `(#x0f #x87 ,@(int->bv32 n)))         ; ja <n>
+
 (define (i386:jump-z n)
   (when (or (> n #x80) (< n #x-80))
     (format (current-error-port) "JUMP-z n=~a\n" n)
     barf)
-  `(#x74 ,(if (>= n 0) n (- n 2)))) ; jz <n>
+  `(#x74 ,(if (>= n 0) n (- n 2))))     ; jz <n>
 
 (define (i386:jump-nz n)
   (when (or (> n #x80) (< n #x-80))
     (format (current-error-port) "JUMP-nz n=~a\n" n)
     barf)
-  `(#x75 ,(if (>= n 0) n (- n 2)))) ; jnz <n>
+  `(#x75 ,(if (>= n 0) n (- n 2))))     ; jnz <n>
 
 (define (i386:test-jump-z n)
   (when (or (> n #x80) (< n #x-80))

module/mes/as-i386.scm

@@ -43,6 +43,7 @@
             i386:accu+value
             i386:accu/base
             i386:accu%base
+            i386:accu*base
             i386:accu-base
             i386:accu-shl
             i386:base-sub
@@ -121,7 +122,9 @@
             i386:Xjump
             i386:Xjump
             i386:Xjump-c
+            i386:Xjump-cz
             i386:Xjump-nc
+            i386:Xjump-ncz
             i386:Xjump-nz
             i386:Xjump-z
 

module/mes/libc.mes

@@ -57,6 +57,9 @@ strlen (char const* s)
   (let* ((ast (with-input-from-string
                   "
 int g_stdin;
+int ungetc_char = -1;
+
+#if 0
 int
 getchar ()
 {
@@ -66,6 +69,62 @@ getchar ()
   if (r < 1) return -1;
   return c;
 }
+#endif
+
+int
+getchar ()
+{
+  char c;
+  int i;
+  if (ungetc_char == -1)
+    {
+      int r = read (g_stdin, &c, 1);
+      if (r < 1) return -1;
+      i = c;
+    }
+  else
+    {
+      i = ungetc_char;
+      ungetc_char = -1;
+    }
+  if (i < 0) i += 256;
+  return i;
+}
+"
+;;paredit:"
+                parse-c99)))
+    ast))
+
+(define assert_fail
+  (let* ((ast (with-input-from-string
+                  "
+void
+assert_fail (char* s)
+{
+  eputs (\"assert fail: \");
+  eputs (s);
+  eputs (\"\n\");
+  //*((int*)0) = 0;
+  char *fail = s;
+  fail = 0;
+  *fail = 0;
+}
+"
+;;paredit:"
+                parse-c99)))
+    ast))
+
+(define ungetc
+  (let* ((ast (with-input-from-string
+"
+#define assert(x) ((x) ? (void)0 : assert_fail (#x))
+int
+ungetc (int c, int fd)
+{
+  assert (ungetc_char == -1);
+  ungetc_char = c;
+  return c;
+}
 "
 ;;paredit:"
                 parse-c99)))
@@ -189,21 +248,15 @@ itoa (int x)
                 parse-c99)))
     ast))
 
-;;;;
+(define isdigit
-
-(define assert_fail
   (let* ((ast (with-input-from-string
                   "
-void
+int
-assert_fail (char* s)
+isdigit (char c)
 {
-  eputs (\"assert fail: \");
+  //return (c>='0') && (c<='9');
-  eputs (s);
+  if (c>='0' && c<='9') return 1;
-  eputs (\"\n\");
+  return 0;
-  //*((int*)0) = 0;
-  char *fail = s;
-  fail = 0;
-  *fail = 0;
 }
 "
 ;;paredit:"
@@ -214,10 +267,12 @@ assert_fail (char* s)
   (list
    strlen
    getchar
+   assert_fail
+   ungetc
    putchar
    eputs
    fputs
    puts
    strcmp
    itoa
-   assert_fail))
+   isdigit))

module/mes/mini-0.mes

@@ -1,7 +1,471 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; bootstrap reader.  This file is read by a minimal core reader.  It
+;;; only supports s-exps and line-comments; quotes, character
+;;; literals, string literals cannot be used here.
+
+;;; Code:
+
 (begin
- (write-byte (make-cell 0 0 65))
+
- (write-byte (make-cell 0 0 66))
+  (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 10))
- (write-byte (make-cell 0 0 67))
+
- (write-byte (make-cell 0 0 10))
+  ((lambda (a+ a)
- #f
+
- )
+     ;; (write-byte (make-cell 0 0 48))
+     ;; (write-byte (make-cell 0 0 48))
+     ;; (write-byte (make-cell 0 0 48))
+     ;; (write-byte (make-cell 0 0 10))
+
+     (set-cdr! a+ (cdr a))
+     (set-cdr! a a+)
+     (set-cdr! (assq (quote *closure*) a) a+)
+     (car a+))
+   (cons (cons (quote env:define) #f) (list))
+   (current-module))
+
+  ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 10))
+
+  (set! env:define
+        (lambda (a+ a)
+
+          ;; (write-byte (make-cell 0 0 48))
+          ;; (write-byte (make-cell 0 0 49))
+          ;; (write-byte (make-cell 0 0 48))
+          ;; (write-byte (make-cell 0 0 10))
+
+          (set-cdr! a+ (cdr a))
+          (set-cdr! a a+)
+          (set-cdr! (assq (quote *closure*) a) a+)
+          (car a+)))
+
+  (env:define (cons (cons (quote <cell:macro>) 5) (list)) (current-module))
+
+  ;; (core:display (quote cm:))
+  ;; (core:display <cell:macro>)
+  ;; (write-byte (make-cell 0 0 10))
+
+  ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 50)) (write-byte (make-cell 0 0 10))
+
+  (env:define (cons (cons (quote <cell:pair>) 7) (list)) (current-module))
+
+  ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 51)) (write-byte (make-cell 0 0 10))
+
+  (env:define (cons (cons (quote sexp:define) #f) (list)) (current-module))
+
+  ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 52)) (write-byte (make-cell 0 0 10))
+
+  (env:define (cons (cons (quote env:macro) #f) (list)) (current-module))
+
+  ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 53)) (write-byte (make-cell 0 0 10))
+
+  (env:define (cons (cons (quote cons*) #f) (list)) (current-module))
+
+  ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 54)) (write-byte (make-cell 0 0 10))
+
+  (env:define (cons (cons (quote not)
+                          (lambda (x) (if x #f #t)))
+                    (list)) (current-module))
+
+  ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 55)) (write-byte (make-cell 0 0 10))
+
+
+  (env:define (cons (cons (quote pair?)
+                          (lambda (x) (eq? (core:type x) <cell:pair>)))
+                    (list)) (current-module))
+
+  ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 56)) (write-byte (make-cell 0 0 10))
+
+
+  (env:define (cons (cons (quote atom?)
+                          (lambda (x) (not (pair? x))))
+                    (list)) (current-module))
+
+  ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 57)) (write-byte (make-cell 0 0 10))
+
+
+  (set! sexp:define
+        (lambda (e a)
+
+          ;; (write-byte (make-cell 0 0 48))
+          ;; (write-byte (make-cell 0 0 57))
+          ;; (write-byte (make-cell 0 0 48))
+          ;; (write-byte (make-cell 0 0 10))
+
+          (if (atom? (cadr e)) (cons (cadr e) (core:eval (car (cddr e)) a))
+              (cons (car (cadr e)) (core:eval (cons (quote lambda) (cons (cdr (cadr e)) (cddr e))) a)))))
+
+  ;; (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 10))
+
+  (set! env:macro
+        (lambda (name+entry)
+
+          (write-byte (make-cell 0 0 49))
+          (write-byte (make-cell 0 0 48))
+          (write-byte (make-cell 0 0 48))
+          (write-byte (make-cell 0 0 10))
+
+
+          (cons
+           (cons (car name+entry)
+                 (make-cell <cell:macro> (core:car (car name+entry)) (cdr name+entry)))
+           (list))))
+
+  ;; (core:display (quote yyy-XXXmacro-m:))
+  ;; (write-byte (make-cell 0 0 10))
+
+  ;; (core:display (quote macro-m:))
+  ;; (core:display (make-cell <cell:macro> core:display 1))
+  ;; (write-byte (make-cell 0 0 10))
+
+  ;; (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 10))
+
+  (set! cons*
+        (lambda (. rest)
+
+          ;; (write-byte (make-cell 0 0 49))
+          ;; (write-byte (make-cell 0 0 49))
+          ;; (write-byte (make-cell 0 0 48))
+          ;; (write-byte (make-cell 0 0 10))
+
+          ;; (core:display (quote rest:))
+          ;; (core:display rest)
+          ;; (write-byte (make-cell 0 0 10))
+
+          (if (null? (cdr rest)) (car rest)
+              (cons (car rest) (core:apply cons* (cdr rest) (current-module))))))
+
+  (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 50)) (write-byte (make-cell 0 0 10))
+
+  (env:define
+   (env:macro
+    (sexp:define
+     (quote
+      (define-macro (define ARGS . BODY)
+
+        ;; (write-byte (make-cell 0 0 49))
+        ;; (write-byte (make-cell 0 0 50))
+        ;; (write-byte (make-cell 0 0 48))
+        ;; (write-byte (make-cell 0 0 10))
+
+        (cons* (quote env:define)
+               (cons* (quote cons)
+                      (cons* (quote sexp:define)
+                             (list (quote quote)
+                                   (cons (quote DEFINE) (cons ARGS BODY)))
+                             (quote ((current-module))))
+                      (quote ((list))))
+               (quote ((current-module))))))
+     (current-module))) (current-module))
+
+  (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 51)) (write-byte (make-cell 0 0 10))
+
+  (env:define
+   (env:macro
+    (sexp:define
+     (quote
+      (define-macro (define-macro ARGS . BODY)
+        (cons* (quote env:define)
+               (list (quote env:macro)
+                     (cons* (quote sexp:define)
+                            (list (quote quote)
+                                  (cons (quote DEFINE-MACRO) (cons ARGS BODY)))
+                            (quote ((current-module)))))
+               (quote ((current-module))))))
+     (current-module))) (current-module))
+
+  (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 52)) (write-byte (make-cell 0 0 10))
+  (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 52)) (write-byte (make-cell 0 0 10))
+
+  ;; (core:display (quote define:))
+  ;; (core:display define)
+  ;; (write-byte (make-cell 0 0 10))
+
+  (define <cell:character> 0)
+
+  ;; (core:display <cell:character>)
+  ;; (write-byte (make-cell 0 0 10))
+  ;; (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 53)) (write-byte (make-cell 0 0 10))
+
+  (define <cell:keyword> 4)
+  (define <cell:string> 10)
+
+  (define (newline . rest) (core:stderr (list->string (list (integer->char 10)))))
+  (define (display x . rest) (core:stderr x))
+
+  (define (list->symbol lst) (make-symbol lst))
+
+  (define (symbol->list s)
+    (core:car s))
+
+  (define (list->string lst)
+    (make-cell <cell:string> lst 0))
+
+  (define (integer->char x)
+    (make-cell <cell:character> 0 x))
+
+  (define (symbol->keyword s)
+    (make-cell <cell:keyword> (symbol->list s) 0))
+
+  (define (read)
+    (read-word (read-byte) (list) (current-module)))
+
+  (define (read-env a)
+    (read-word (read-byte) (list) a))
+
+  (define (read-input-file)
+    (define (helper x)
+      (if (null? x) x
+          (cons x (helper (read)))))
+    (helper (read)))
+
+  (define-macro (cond . clauses)
+    (list (quote if) (pair? clauses)
+          (list (quote if) (car (car clauses))
+                (if (pair? (cdar clauses))
+                    (if (eq? (car (cdar clauses)) (quote =>))
+                        (append2 (cdr (cdar clauses)) (list (caar clauses)))
+                        (list (cons (quote lambda) (cons (list) (car clauses)))))
+                    (list (cons (quote lambda) (cons (list) (car clauses)))))
+                (if (pair? (cdr clauses))
+                    (cons (quote cond) (cdr clauses))))))
+
+  (define (eat-whitespace c)
+    (cond
+     ((eq? c 32) (eat-whitespace (read-byte)))
+     ((eq? c 10) (eat-whitespace (read-byte)))
+     ((eq? c 9) (eat-whitespace (read-byte)))
+     ((eq? c 12) (eat-whitespace (read-byte)))
+     ((eq? c 13) (eat-whitespace (read-byte)))
+     ((eq? c 59) (begin (read-line-comment c)
+                        (eat-whitespace (read-byte))))
+     ((eq? c 35) (cond ((eq? (peek-byte) 33)
+                        (read-byte)
+                        (read-block-comment 33 (read-byte))
+                        (eat-whitespace (read-byte)))
+                       ((eq? (peek-byte) 59)
+                        (read-byte)
+                        (read-word (read-byte) (list) (list))
+                        (eat-whitespace (read-byte)))
+                       ((eq? (peek-byte) 124)
+                        (read-byte)
+                        (read-block-comment 124 (read-byte))
+                        (eat-whitespace (read-byte)))
+                       (#t (unread-byte 35))))
+     (#t (unread-byte c))))
+
+
+  (define (read-block-comment s c)
+    (if (eq? c s) (if (eq? (peek-byte) 35) (read-byte)
+                      (read-block-comment s (read-byte)))
+        (read-block-comment s (read-byte))))
+
+  (define (read-line-comment c)
+    (if (eq? c 10) c
+        (read-line-comment (read-byte))))
+
+  (define (read-list a)
+    (eat-whitespace (read-byte))
+    (if (eq? (peek-byte) 41) (begin (read-byte) (list))
+        ((lambda (w)
+           (if (eq? w *dot*) (car (read-list a))
+               (cons w (read-list a))))
+         (read-word (read-byte) (list) a))))
+
+  (define-macro (and . x)
+    (if (null? x) #t
+        (if (null? (cdr x)) (car x)
+            (list (quote if) (car x) (cons (quote and) (cdr x))
+                  #f))))
+
+  (define-macro (or . x)
+    (if (null? x) #f
+        (if (null? (cdr x)) (car x)
+            (list (quote if) (car x) (car x)
+                  (cons (quote or) (cdr x))))))
+  (define (not x)
+    (if x #f #t))
+  
+  (define (read-character)
+    (define (read-octal c p n)
+      (if (not (and (> p 47) (< p 56))) n
+          (read-octal (read-byte) (peek-byte) (+ (ash n 3) (- p 48)))))
+
+    (define (read-name c p n)
+      (define (lookup-char n)
+        (cond ((assq n (quote ((*foe* . -1)
+                               (lun . 0)
+                               (mrala . 7)
+                               (ecapskcab . 8)
+                               (bat . 9)
+                               (enilwen . 10)
+                               (batv . 11)
+                               (egap . 12)
+                               (nruter . 13)
+                               (ecaps . 32)))) => cdr)
+              (#t (error (quote char-not-supported) n))))
+      (if (not (or (eq? p 42) (and (> p 96) (< p 123)))) (integer->char (lookup-char (list->symbol (cons (integer->char c) n))))
+          (read-name (read-byte) (peek-byte) (cons (integer->char c) n))))
+
+    ((lambda (c p)
+       (cond ((and (> c 47) (< c 56) (> p 47) (< p 56))
+              (integer->char (read-octal c p (- c 48))))
+             ((and (or (= c 42) (and (> c 96) (< c 123)))
+                   (or (= p 42) (and (> p 96) (< p 123)))) (read-name c p (list)))
+             (#t (integer->char c))))
+     (read-byte) (peek-byte)))
+
+  (define (read-hex)
+    (define (calc c)
+      (cond ((and (> c 64) (< c 71)) (+ (- c 65) 10))
+            ((and (> c 96) (< c 103)) (+ (- c 97) 10))
+            ((and (> c 47) (< c 58)) (- c 48))
+            (#t 0)))
+    (define (read-hex c p n)
+      (if (not (or (and (> p 64) (< p 71))
+                   (and (> p 96) (< p 103))
+                   (and (> p 47) (< p 58)))) (+ (ash n 4) (calc c))
+                   (read-hex (read-byte) (peek-byte) (+ (ash n 4) (calc c)))))
+    ((lambda (c p)
+       (read-hex c p 0))
+     (read-byte) (peek-byte)))
+
+  (define (read-string)
+    (define (append-char s c)
+      (append2 s (cons (integer->char c) (list))))
+    (define (read-string c p s)
+      (cond
+       ((and (eq? c 92) (or (eq? p 92) (eq? p 34)))
+        ((lambda (c)
+           (read-string (read-byte) (peek-byte) (append-char s c)))
+         (read-byte)))
+       ((and (eq? c 92) (eq? p 110))
+        (read-byte)
+        (read-string (read-byte) (peek-byte) (append-char s 10)))
+       ((eq? c 34) s)
+       ((eq? c -1) (error (quote EOF-in-string)))
+       (#t (read-string (read-byte) (peek-byte) (append-char s c)))))
+    (list->string (read-string (read-byte) (peek-byte) (list))))
+
+  (define (map1 f lst)
+    (if (null? lst) (list)
+        (cons (f (car lst)) (map1 f (cdr lst)))))
+
+  (define (lookup w a)
+    (core:lookup (map1 integer->char w) a))
+
+  (define (read-hash c w a)
+    (cond
+     ((eq? c 33) (begin (read-block-comment 33 (read-byte))
+                        (read-word (read-byte) w a)))
+     ((eq? c 124) (begin (read-block-comment 124 (read-byte))
+                         (read-word (read-byte) w a)))
+     ((eq? c 40) (list->vector (read-list a)))
+     ((eq? c 92) (read-character))
+     ((eq? c 120) (read-hex))
+     ((eq? c 44) (cond ((eq? (peek-byte) 64)
+                        (read-byte)
+                        (cons (quote unsyntax-splicing)
+                              (cons (read-word (read-byte) w a) w)))
+                       (#t (cons (quote unsyntax)
+                                 (cons (read-word (read-byte) w a) w)))))
+     ((eq? c 39) (cons (quote syntax) (cons (read-word (read-byte) w a) w)))
+     ((eq? c 58) (symbol->keyword (read-word (read-byte) w a)))
+     ((eq? c 59) (begin (read-word (read-byte) w a)
+                        (read-word (read-byte) w a)))
+     ((eq? c 96) (cons (quote quasisyntax)
+                       (cons (read-word (read-byte) w a) w)))
+     (#t (read-word c (append2 w (cons 35 w)) a))))
+    
+  (define (read-word c w a)
+
+     (write-byte (make-cell 0 0 66))
+     (write-byte (make-cell 0 0 66))
+     (write-byte (make-cell 0 0 58))
+     (write-byte c)
+     (write-byte (make-cell 0 0 10))
+
+    (cond
+     ((or (and (> c 96) (< c 123))
+          (eq? c 45)
+          (eq? c 63)
+          (and (> c 47) (< c 58)))
+      (read-word (read-byte) (append2 w (cons c (list))) a))
+     ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
+     ((eq? c 40) (if (null? w) (read-list a)
+                     (begin (unread-byte c) (lookup w a))))
+     ((eq? c 41) (if (null? w) (quote *FOOBAR*)
+                     (begin (unread-byte c) (lookup w a))))
+     ((eq? c 34) (if (null? w) (read-string)
+                     (begin (unread-byte c) (lookup w a))))
+     ((eq? c 32) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
+     ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
+     ((eq? c 35) (read-hash (read-byte) w a))
+     ((eq? c 39) (if (null? w) (cons (quote quote)
+                                     (cons (read-word (read-byte) w a) (list)))
+                     (begin (unread-byte c) (lookup w a))))
+     ((eq? c 44) (cond
+                  ((eq? (peek-byte) 64)
+                   (begin (read-byte)
+                          (cons
+                           (quote unquote-splicing)
+                           (cons (read-word (read-byte) w a) (list)))))
+                  (#t (cons (quote unquote)
+                            (cons (read-word (read-byte) w a) (list))))))
+     ((eq? c 96) (cons (quote quasiquote) (cons (read-word (read-byte) w a) (list))))
+     ((eq? c 59) (read-line-comment c) (read-word 10 w a))
+     ((eq? c 9) (read-word 32 w a))
+     ((eq? c 12) (read-word 32 w a))
+     ((eq? c -1) (list))
+     (#t (read-word (read-byte) (append2 w (cons c (list))) a))))
+
+  (write-byte (make-cell 0 0 65))
+  (write-byte (make-cell 0 0 66))
+  (write-byte (make-cell 0 0 67))
+  (write-byte (make-cell 0 0 10))
+
+  (core:display (quote bla-bla))
+  (write-byte (make-cell 0 0 10))
+
+  ((lambda (p)
+     ;;(core:display (quote here-we-go))
+     (write-byte (make-cell 0 0 65))
+     (write-byte (make-cell 0 0 65))
+     (write-byte (make-cell 0 0 65))
+     (write-byte (make-cell 0 0 65))
+     (write-byte (make-cell 0 0 10))
+
+     (core:display (quote blub-blub))
+     (write-byte (make-cell 0 0 10))
+
+     (write-byte (make-cell 0 0 112))
+     (write-byte (make-cell 0 0 58))
+     ;;(core:display (quote p:))
+     (core:display p)
+     (write-byte (make-cell 0 0 10))
+     (core:eval (cons (quote begin) p) (current-module)))
+   (read-input-file))
+  
+  ;;(read-input-file)
+
+)

posix.c

@@ -53,26 +53,6 @@ char const* string_to_cstring (SCM);
 //   return cell_unspecified;
 // }
 
-int
-getchar ()
-{
-  return getc (g_stdin);
-}
-
-int
-ungetchar (int c)
-{
-  return ungetc (c, g_stdin);
-}
-
-int
-peekchar ()
-{
-  int c = getchar ();
-  ungetchar (c);
-  return c;
-}
-
 SCM
 getenv_ (SCM s) ///((name . "getenv"))
 {
@@ -80,24 +60,45 @@ getenv_ (SCM s) ///((name . "getenv"))
   return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
 }
 
-SCM
+// MINI_MES
-peek_byte ()
+// int
-{
+// getchar ()
-  return MAKE_NUMBER (peekchar ());
+// {
-}
+//   return getc (g_stdin);
+// }
 
-SCM
+// int
-read_byte ()
+// ungetchar (int c)
-{
+// {
-  return MAKE_NUMBER (getchar ());
+//   return ungetc (c, g_stdin);
-}
+// }
 
-SCM
+// int
-unread_byte (SCM i)
+// peekchar ()
-{
+// {
-  ungetchar (VALUE (i));
+//   int c = getchar ();
-  return i;
+//   ungetchar (c);
-}
+//   return c;
+// }
+
+// SCM
+// peek_byte ()
+// {
+//   return MAKE_NUMBER (peekchar ());
+// }
+
+// SCM
+// read_byte ()
+// {
+//   return MAKE_NUMBER (getchar ());
+// }
+
+// SCM
+// unread_byte (SCM i)
+// {
+//   ungetchar (VALUE (i));
+//   return i;
+// }
 
 SCM
 force_output (SCM p) ///((arity . n))

reader.c

@@ -86,25 +86,26 @@ read_env (SCM a)
   return read_word (getchar (), cell_nil, a);
 }
 
-SCM
+//MINI_MES
-lookup_ (SCM s, SCM a)
+// SCM
-{
+// lookup_ (SCM s, SCM a)
-  if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) {
+// {
-    SCM p = s;
+//   if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) {
-    int sign = 1;
+//     SCM p = s;
-    if (VALUE (car (s)) == '-') {
+//     int sign = 1;
-      sign = -1;
+//     if (VALUE (car (s)) == '-') {
-      p = cdr (s);
+//       sign = -1;
-    }
+//       p = cdr (s);
-    int n = 0;
+//     }
-    while (p != cell_nil && isdigit (VALUE (car (p)))) {
+//     int n = 0;
-      n *= 10;
+//     while (p != cell_nil && isdigit (VALUE (car (p)))) {
-      n += VALUE (car (p)) - '0';
+//       n *= 10;
-      p = cdr (p);
+//       n += VALUE (car (p)) - '0';
-    }
+//       p = cdr (p);
-    if (p == cell_nil) return MAKE_NUMBER (n * sign);
+//     }
-  }
+//     if (p == cell_nil) return MAKE_NUMBER (n * sign);
+//   }
 
-  SCM x = lookup_symbol_ (s);
+//   SCM x = lookup_symbol_ (s);
-  return x ? x : make_symbol_ (s);
+//   return x ? x : make_symbol_ (s);
-}
+// }

scaffold/mini-mes.c

@@ -24,7 +24,7 @@
 #define assert(x) ((x) ? (void)0 : assert_fail (#x))
 
 #define MES_MINI 1
-#define FIXED_PRIMITIVES 0
+#define FIXED_PRIMITIVES 1
 
 #if __GNUC__
 #define FIXME_NYACC 1
@@ -37,8 +37,10 @@
 #define NYACC_CDR nyacc_cdr
 #endif
 
-int ARENA_SIZE = 1200000;
+// int ARENA_SIZE = 1200000;
-char arena[1200000];
+// char arena[1200000];
+int ARENA_SIZE = 2000000;
+char arena[2000000];
 
 typedef int SCM;
 
@@ -178,12 +180,9 @@ int g_function = 0;
 #define CDR(x) g_cells[x].cdr
 #define CLOSURE(x) g_cells[x].cdr
 #define CONTINUATION(x) g_cells[x].cdr
-#if __GNUC__
-//#define FUNCTION(x) g_functions[g_cells[x].function]
-#endif
 
 #define FUNCTION(x) g_functions[g_cells[x].cdr]
-#define MACRO(x) g_cells[x].car
+#define MACRO(x) g_cells[x].cdr
 #define VALUE(x) g_cells[x].cdr
 #define VECTOR(x) g_cells[x].cdr
 
@@ -284,6 +283,12 @@ cdr (SCM x)
   return CDR(x);
 }
 
+SCM
+list (SCM x) ///((arity . n))
+{
+  return x;
+}
+
 SCM
 null_p (SCM x)
 {
@@ -330,16 +335,97 @@ cdr_ (SCM x)
           || TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
 }
 
+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
+error (SCM key, SCM x)
+{
+  SCM throw;
+  if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
+    return apply (throw, cons (key, cons (x, cell_nil)), r0);
+  eputs ("error");
+  assert (0);
+}
+
 SCM
 assert_defined (SCM x, SCM e) ///((internal))
 {
   if (e != cell_undefined) return e;
   // error (cell_symbol_unbound_variable, x);
-  puts ("unbound variable");
+  eputs ("unbound variable: ");
+  display_ (x);
+  eputs ("\n");
   exit (33);
   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)
+    {
+      // FIXME
+      //char buf[1024];
+      char buf = "TODO:check_formals";
+      // sprintf (buf, "apply: wrong number of arguments; expected: %d, got: %d: ", flen, alen);
+      eputs ("apply: wrong number of arguments; expected: ");
+      eputs (itoa (flen));
+      eputs (", got: ");
+      eputs (itoa (alen));
+      eputs ("\n");
+      display_ (f);
+      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;
+  char* 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)
+    {
+      //FIXME
+      //char buf[1024];
+      char buf = "TODO:check_apply";
+      // sprintf (buf, "cannot apply: %s:", type);
+      // fprintf (stderr, " [");
+      // stderr_ (e);
+      // fprintf (stderr, "]\n");
+      eputs ("cannot apply: ");
+      eputs (type);
+      eputs ("[");
+      display_ (e);
+      eputs ("]\n");
+      SCM e = MAKE_STRING (cstring_to_list (buf));
+      return error (cell_symbol_wrong_type_arg, cons (e, f));
+    }
+  return cell_unspecified;
+}
+
 SCM
 gc_push_frame () ///((internal))
 {
@@ -348,6 +434,14 @@ gc_push_frame () ///((internal))
   return g_stack;
 }
 
+SCM
+apply (SCM f, SCM x, SCM a) ///((internal))
+{
+  push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
+  r3 = cell_vm_apply;
+  return eval_apply ();
+}
+
 SCM
 append2 (SCM x, SCM y)
 {
@@ -380,6 +474,12 @@ call (SCM fn, SCM x)
   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
       && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
+#if 0
+  eputs ("call: ");
+  if (FUNCTION (fn).name) eputs (FUNCTION (fn).name);
+  else eputs (itoa (CDR (fn)));
+  eputs ("\n");
+#endif
   switch (FUNCTION (fn).arity)
     {
     case 0: {return (FUNCTION (fn).function) ();}
@@ -457,6 +557,18 @@ lookup_macro (SCM x, SCM a)
 {
   if (TYPE (x) != TSYMBOL) return cell_f;
   SCM m = assq_ref_env (x, a);
+#if 0
+  if (TYPE (m) == TMACRO)
+    {
+      fputs ("XXmacro: ", 1);
+      fputs ("[", 1);
+      fputs (itoa (m), 1);
+      fputs ("]: ", 1);
+      display_ (m);
+      fputs ("\n", 1);
+
+    }
+#endif
   if (TYPE (m) == TMACRO) return MACRO (m);
   return cell_f;
 }
@@ -536,7 +648,7 @@ eval_apply ()
   switch (TYPE (car (r1)))
     {
     case TFUNCTION: {
-      //check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
+      check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
       r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
       goto vm_return;
     }
@@ -547,7 +659,7 @@ eval_apply ()
         SCM body = cddr (cl);
         SCM aa = cdar (cl);
         aa = cdr (aa);
-        //check_formals (car (r1), formals, cdr (r1));
+        check_formals (car (r1), formals, cdr (r1));
         SCM p = pairlis (formals, cdr (r1), aa);
         call_lambda (body, p, aa, r0);
         goto begin;
@@ -579,7 +691,7 @@ eval_apply ()
               r1 = cdr (r1);
               goto call_with_current_continuation;
             }
-            //default: check_apply (cell_f, car (r1));
+          default: check_apply (cell_f, car (r1));
           }
       }
     case TSYMBOL:
@@ -605,7 +717,7 @@ eval_apply ()
               SCM formals = cadr (car (r1));
               SCM body = cddr (car (r1));
               SCM p = pairlis (formals, cdr (r1), r0);
-              //check_formals (r1, formals, cdr (r1));
+              check_formals (r1, formals, cdr (r1));
               call_lambda (body, p, p, r0);
               goto begin;
             }
@@ -615,7 +727,7 @@ eval_apply ()
   push_cc (car (r1), r1, r0, cell_vm_apply2);
   goto eval;
  apply2:
-  //check_apply (r1, car (r2));
+  check_apply (r1, car (r2));
   r1 = cons (r1, cdr (r2));
   goto apply;
 
@@ -716,6 +828,14 @@ eval_apply ()
       && (macro = lookup_macro (car (r1), r0)) != cell_f)
     {
       r1 = cons (macro, CDR (r1));
+#if 0
+      puts ("macro: ");
+      display_ (macro);
+      puts ("\n");
+      puts ("r1: ");
+      display_ (r1);
+      puts ("\n");
+#endif
       goto apply;
     }
   else if (TYPE (r1) == TPAIR
@@ -749,6 +869,11 @@ eval_apply ()
     if (CDR (r1) == cell_nil)
       {
         r1 = car (r1);
+#if 0
+        puts ("begin: ");
+        display_ (r1);
+        puts ("\n");
+#endif
         goto eval;
       }
     push_cc (CAR (r1), r1, r0, cell_vm_begin2);
@@ -881,25 +1006,51 @@ SCM
 lookup_symbol_ (SCM s)
 {
   SCM x = g_symbols;
-#if !MES_MINI
   while (x) {
-    if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
+    //if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
+    if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) goto dun;
     x = cdr (x);
   }
+ dun:
   if (x) x = car (x);
-#endif;
   return x;
 }
 
 SCM
 make_symbol (SCM s)
 {
-#if MES_MINI
-  return make_symbol_ (s);
-#else
   SCM x = lookup_symbol_ (s);
   return x ? x : make_symbol_ (s);
+}
+
+//MINI_MES reader.c
+SCM
+lookup_ (SCM s, SCM a)
+{
+  if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) {
+    SCM p = s;
+    int sign = 1;
+    if (VALUE (car (s)) == '-') {
+      sign = -1;
+      p = cdr (s);
+    }
+    int n = 0;
+    while (p != cell_nil && isdigit (VALUE (car (p)))) {
+#if __GNUC__
+      //FIXME
+      n *= 10;
+      n += VALUE (car (p)) - '0';
+#else
+      n = n * 10;
+      n = n + VALUE (car (p)) - '0';
 #endif
+      p = cdr (p);
+    }
+    if (p == cell_nil) return MAKE_NUMBER (n * sign);
+  }
+
+  SCM x = lookup_symbol_ (s);
+  return x ? x : make_symbol_ (s);
 }
 
 SCM
@@ -925,6 +1076,45 @@ acons (SCM key, SCM value, SCM alist)
 
 // MINI_MES: temp-lib
 
+// int
+// getchar ()
+// {
+//   return getc (g_stdin);
+// }
+
+int
+ungetchar (int c)
+{
+  return ungetc (c, g_stdin);
+}
+
+int
+peekchar ()
+{
+  int c = getchar ();
+  ungetchar (c);
+  return c;
+}
+
+SCM
+peek_byte ()
+{
+  return MAKE_NUMBER (peekchar ());
+}
+
+SCM
+read_byte ()
+{
+  return MAKE_NUMBER (getchar ());
+}
+
+SCM
+unread_byte (SCM i)
+{
+  ungetchar (VALUE (i));
+  return i;
+}
+
 SCM
 write_byte (SCM x) ///((arity . n))
 {
@@ -968,6 +1158,13 @@ display_ (SCM x)
         puts ("]>");
         break;
       }
+    case TMACRO:
+      {
+        puts ("#<macro ");
+        display_ (cdr (x));
+        puts (">");
+        break;
+      }
     case TNUMBER:
       {
         //puts ("<number>\n");
@@ -991,25 +1188,19 @@ display_ (SCM x)
         break;
       }
     case TSPECIAL:
-      {
+#if __NYACC__
-        switch (x)
+      // FIXME
-          {
+      {}
-          case 1: {puts ("()"); break;}
+#endif
-          case 2: {puts ("#f"); break;}
+    case TSTRING:
-          case 3: {puts ("#t"); break;}
+#if __NYACC__
-          default:
+      // FIXME
-            {
+      {}
-        puts ("<x:");
+#endif
-        puts (itoa (x));
-        puts (">");
-            }
-          }
-        break;
-      }
     case TSYMBOL:
       {
         SCM t = CAR (x);
-        while (t != cell_nil)
+        while (t && t != cell_nil)
           {
             putchar (VALUE (CAR (t)));
             t = CDR (t);
@@ -1073,16 +1264,15 @@ mes_symbols () ///((internal))
 
   #include "mini-mes.symbol-names.i"
 
-  // a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
+  a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
-  // a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
+  a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
 
   a = acons (cell_symbol_dot, cell_dot, a);
   a = acons (cell_symbol_begin, cell_begin, a);
+  a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
+  a = acons (cell_symbol_sc_expand, cell_f, a);
   a = acons (cell_closure, a, a);
 
-  // a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
-  // a = acons (cell_symbol_sc_expand, cell_f, a);
-
   return a;
 }
 
@@ -1208,6 +1398,38 @@ stderr_ (SCM x)
   return cell_unspecified;
 }
 
+//math.c
+#define INT_MIN -2147483648
+#define INT_MAX 2147483647
+
+SCM
+greater_p (SCM x) ///((name . ">") (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;
+}
+
 int
 main (int argc, char *argv[])
 {

scaffold/t.c

@@ -382,6 +382,12 @@ test (char *p)
   puts ("t: if (one < 0)\n");
   if (one < 0) return 1;
 
+  puts ("t: if (one <= 0)\n");
+  if (one <= 0) return 1;
+
+  puts ("t: if (one >= 2)\n");
+  if (one >= 2) return 1;
+
   puts ("t: if (strlen (\"\"))\n");
   if (strlen ("")) return 1;
 
@@ -554,11 +560,30 @@ test (char *p)
  ok2:
 
   puts ("t: if (one < 2)\n");
-  //if (one < 2) goto ok3;
+  if (one < 2) goto ok3;
-  if (one < 0x44) goto ok3;
   return 1;
  ok3:
 
+  puts ("t: if (one >= 0)\n");
+  if (one >= 0) goto ok30;
+  return 1;
+ ok30:
+
+  puts ("t: if (one >= 1)\n");
+  if (one >= 0) goto ok31;
+  return 1;
+ ok31:
+
+  puts ("t: if (one <= 2)\n");
+  if (one <= 2) goto ok32;
+  return 1;
+ ok32:
+
+  puts ("t: if (one <= 1)\n");
+  if (one <= 1) goto ok33;
+  return 1;
+ ok33:
+
   puts ("t: if (strlen (\".\"))\n");
   if (strlen (".")) goto ok4;
   return 1;