mescc: Support struct assignment.
authorJan Nieuwenhuizen <janneke@gnu.org>
Thu, 2 Mar 2017 19:26:13 +0000 (20:26 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Thu, 2 Mar 2017 19:26:13 +0000 (20:26 +0100)
* module/mes/libc-i386.mes (i386:base-address->accu-address,
  i386:accu+n, i386:base+n): New functions.
* module/mes/libc-i386.scm: Export them.
* module/language/c99/compiler.mes (ast->info): Use them.
* doc/examples/t.c: Test them.
* doc/examples/cons-mes.c: Drop workarounds.
* doc/examples/mini-mes.c: Likewise.
* mes.c:

build-aux/mes-snarf.scm
mes.c
module/language/c99/compiler.mes
module/mes/libc-i386.mes
module/mes/libc-i386.scm
scaffold/cons-mes.c
scaffold/mini-mes.c
scaffold/t.c

index 28529845fb73d2323f98cbc9f37745332dd959d9..dda015e20b212971d384bb57aace36372a1c6c52 100755 (executable)
@@ -104,7 +104,7 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
 (define (function->source f i)
   (string-append
    (format #f "~a.function = g_function;\n" (function-builtin-name f))
-   (format #f "functions[g_function++] = fun_~a;\n" (.name f))
+   (format #f "g_functions[g_function++] = fun_~a;\n" (.name f))
    (format #f "cell_~a = g_free++;\n" (.name f))
    (format #f "g_cells[cell_~a] = ~a;\n\n" (.name f) (function-builtin-name f))))
 
diff --git a/mes.c b/mes.c
index 51313500dba5574d0bb4a1881ad0270879eaeb6b..cc53d4a1184ae2d6b7021b93a05ca8830eed0d74 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -171,7 +171,7 @@ SCM tmp;
 SCM tmp_num;
 SCM tmp_num2;
 
-function_t functions[200];
+function_t g_functions[200];
 int g_function = 0;
 
 SCM g_continuations = 0;
@@ -201,7 +201,7 @@ SCM r3 = 0; // continuation
 #define REF(x) g_cells[x].ref
 #define VALUE(x) g_cells[x].value
 #define VECTOR(x) g_cells[x].vector
-#define FUNCTION(x) functions[g_cells[x].function]
+#define FUNCTION(x) g_functions[g_cells[x].function]
 #define NCAR(x) g_news[x].car
 #define NTYPE(x) g_news[x].type
 
index cbaaf3a1bb5f16ab131627f71901d13859beacd0..89a784e6c64dc44c776b4340ec96beed9e4a09ba 100644 (file)
   (and=> (ident->decl info o) car))
 
 (define (ident->pointer info o)
-  (or (and=> (ident->decl info o) global:pointer) 0))
+  (let ((local (assoc-ref (.locals info) o)))
+    (if local (local:pointer local)
+        (or (and=> (ident->decl info o) global:pointer) 0))))
 
 (define (type->description info o)
   ;; (stderr  "type->description =~s\n" o)  
                     #:locals locals))))
         
         ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
-        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list ,param-list)) (initzer ,initzer))))
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list ,param-list)) (initzer ,initzer))))
          (let* ((locals (add-local locals name type 1))
                 (info (clone info #:locals locals))
                 (empty (clone info #:text '()))
                                       ((base->ident info) name)))))
         
         ;; *p = 0;
-        ((expr-stmt (assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))
+        ((expr-stmt (assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b))
          (when (not (equal? op "="))
            (stderr "OOOPS2: op=~s\n" op)
            barf)
            (clone info #:text (append text
                                       (.text base)
                                       ;;assign:
-                                      ((base->ident-address info) name)))))
+                                      ((base->ident-address info) array)))))
 
         ;; g_cells[0] = 65;
-        ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op ,op) ,b))
+        ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))) (op ,op) ,b))
          (when (not (equal? op "="))
            (stderr "OOOPS3: op=~s\n" op)
            barf)
          (let* ((index (cstring->number index))
                 (empty (clone info #:text '()))
-                (base ((expr->base empty) b)))
+                (base ((expr->base empty) b))
+                (type (ident->type info array))
+                (fields (or (type->description info type) '()))  ;; FIXME: struct!
+                (size (type->size info type))
+                (count (length fields))
+                (field-size 4) ;; FIXME:4, not fixed
+                (ptr (ident->pointer info array)))
           (clone info #:text
                  (append text
                          (.text base)
-
                          (list (lambda (f g ta t d)
                                  (i386:push-base)))
-                         ((ident->base info) name)
                          (list (lambda (f g ta t d)
                                  (append
-                                  (i386:value->accu index)
-                                  (i386:accu+base))))
+                                  (i386:value->base index)
+                                  (i386:base->accu)
+                                  (if (> count 1) (i386:accu+accu) '())
+                                  (if (= count 3) (i386:accu+base) '())
+                                  (i386:accu-shl 2))))
+                         ((ident->base info) array)
+                          (list (lambda (f g tav t d)
+                                  (i386:accu+base)))
                          (list (lambda (f g ta t d)
                                  (i386:pop-base)))
-
-                         (list (lambda (f g ta t d)
-                                 (i386:base->accu-address)))))))
+                         (cond ((equal? array "g_functions") ;; FIXME
+                                (list (lambda (f g ta t d)
+                                        (append
+                                         (i386:base-address->accu-address)
+                                         (i386:accu+n 4)
+                                         (i386:base+n 4)
+                                         (i386:base-address->accu-address)))))
+                               (else (list (lambda (f g ta t d)
+                                             (i386:base->accu-address)))))))))
 
         ;; g_cells[i] = c;
-        ((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,name))) (op ,op) ,b))
+        ((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) (op ,op) ,b))
+         (stderr "g_cells4[]: ~s\n" array)
+         ;;(stderr "pointer_cells4[]: ~s\n" array)
          (when (not (equal? op "="))
            (stderr "OOOPS4: op=~s\n" op)
            barf)
          (let* ((empty (clone info #:text '()))
-                (base ((expr->base empty) b)))
+                (base ((expr->base empty) b))
+                (type (ident->type info array))
+                (fields (or (type->description info type) '()))  ;; FIXME: struct!
+                (size (type->size info type))
+                (count (length fields))
+                (field-size 4) ;; FIXME:4, not fixed
+                (ptr (ident->pointer info array)))
+           (stderr "g_cells4[~a]: type=~a\n" array type)
+           (stderr "g_cells4[~a]: pointer=~a\n" array ptr)
+           (stderr "g_cells4[~a]: fields=~a\n" array fields)
+           (stderr "g_cells4[~a]: size=~a\n" array size)
+           (stderr "g_cells4[~a]: count=~a\n" array count)
            (clone info #:text
                   (append text
                           (.text base)
-
-                         (list (lambda (f g ta t d)
-                                 (i386:push-base)))
-                          ((ident->base info) name)
-                          ((ident->accu info) index)  ;; FIXME: chars! index*size
                           (list (lambda (f g ta t d)
-                                  (i386:accu+base))) ; FIXME: type: char
+                                  (i386:push-base)))
+                          ((ident->base info) index)
+                          (list (lambda (f g ta t d)
+                                  (append
+                                   (i386:base->accu)
+                                   (if (> count 1) (i386:accu+accu) '())
+                                   (if (= count 3) (i386:accu+base) '())
+                                   (i386:accu-shl 2))))
+                          ((ident->base info) array)
+                          (list (lambda (f g ta t d)
+                                  (i386:accu+base)))
                          (list (lambda (f g ta t d)
                                  (i386:pop-base)))
-
-                          (list (lambda (f g ta t d)
-                                  ;;(i386:byte-base->accu-address)
-                                  (i386:base->accu-address)
-                                  ))))))
+                         (cond ((equal? array "g_functions") ;; FIXME
+                                (list (lambda (f g ta t d)
+                                        (append
+                                         (i386:base-address->accu-address)
+                                         (i386:accu+n 4)
+                                         (i386:base+n 4)
+                                         (i386:base-address->accu-address)))))
+                               (else (list (lambda (f g ta t d)
+                                             (i386:base->accu-address)))))))))
 
         ;; g_functions[g_function++] = g_foo;
-        ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,name))) (op ,op) ,b))
+        ((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,array))) (op ,op) ,b))
          (when (not (equal? op "="))
            (stderr "OOOPS5: op=~s\n" op)
            barf)
          (let* ((empty (clone info #:text '()))
-                (base ((expr->base empty) b)))
+                (base ((expr->base empty) b))
+                (type (ident->type info array))
+                (fields (or (type->description info type) '()))  ;; FIXME: struct!
+                (size (type->size info type))
+                (count (length fields))
+                (field-size 4) ;; FIXME:4, not fixed
+                (ptr (ident->pointer info array)))
+           (stderr "g_cells5[~a]: type=~a\n" array type)
+           (stderr "g_cells5[~a]: pointer=~a\n" array ptr)
+           (stderr "g_cells5[~a]: fields=~a\n" array fields)
+           (stderr "g_cells5[~a]: size=~a\n" array size)
+           (stderr "g_cells5[~a]: count=~a\n" array count)
            (clone info #:text
                   (append text
                           (.text base)
-
-                          (list (lambda (f g ta t d)
-                                 (i386:push-base)))
-                          ((ident->base info) name)
-                          ((ident->accu info) index)  ;; FIXME: chars! index*size
                           (list (lambda (f g ta t d)
-                                  (i386:accu+base))) ; FIXME: type: char
-                          (list (lambda (f g ta t d)
-                                  (i386:pop-base)))
-
+                                  (i386:push-base)))
+                          ((ident->base info) index)
                           (list (lambda (f g ta t d)
                                   (append
-                                   (i386:base->accu-address))))
-
-                          ((ident-add info) index 1)
-                          ))))
+                                   (i386:base->accu)
+                                   (if (> count 1) (i386:accu+accu) '())
+                                   (if (= count 3) (i386:accu+base) '())
+                                   (i386:accu-shl 2))))
+                          ((ident->base info) array)
+                          (list (lambda (f g ta t d)
+                                  (i386:accu+base)))
+                         (list (lambda (f g ta t d)
+                                 (i386:pop-base)))
+                         ;; FIXME
+                         (cond ((equal? array "g_functions") ;; FIXME
+                                (list (lambda (f g ta t d)
+                                        (append
+                                         (i386:base-address->accu-address)
+                                         (i386:accu+n 4)
+                                         (i386:base+n 4)
+                                         (i386:base-address->accu-address)))))
+                               (else (list (lambda (f g ta t d)
+                                             (i386:base->accu-address)))))
+                         ((ident-add info) index 1)))))
 
         ;; DECL
         ;;
index 7fb2f81876f223576cfefacb0c1942d15a67f601..f6ae7c54d06d471bb455e29cce11d13adf62a3b0 100644 (file)
 (define (i386:base->accu-address)
   '(#x89 #x10))                         ; mov    %edx,(%eax)
 
+(define (i386:base-address->accu-address)
+  '(#x8b #x0a                           ; mov    (%edx),%ecx
+    #x89 #x08))                         ; mov    %ecx,(%eax)
+
+(define (i386:accu+n n)
+  `(#x83 #xc0 ,n))                      ; add    $0x00,%eax
+
+(define (i386:base+n n)
+  `(#x83 #xc2 ,n))                      ; add    $0x00,%edx
+
 (define (i386:byte-base->accu-address)
   '(#x88 #x10))                         ; mov    %dl,(%eax)
 
index 5e2a929f3ddec5099384089b0a31c0f0534df123..3f2762b700863cb2bf46c14a44bf9b8b0f560dda 100644 (file)
 
             i386:XXjump
 
+            i386:accu+n
+            i386:base+n
+            i386:base-address->accu-address
+
             ;; libc
             i386:exit
             i386:open
index 77c892945a879856258f5a0c7a0decae1b7cf93f..290617c9fde619434032698ec646cff4413c0395 100644 (file)
@@ -336,7 +336,7 @@ SCM tmp_num;
 SCM tmp_num2;
 
 int ARENA_SIZE = 200;
-struct function functions[2];
+struct function g_functions[5];
 int g_function = 0;
 
 
@@ -393,10 +393,10 @@ SCM cell_cdr;
 #endif
 #define CONTINUATION(x) g_cells[x].cdr
 #if __GNUC__
-//#define FUNCTION(x) functions[g_cells[x].function]
+//#define FUNCTION(x) g_functions[g_cells[x].function]
 #endif
 
-#define FUNCTION(x) functions[g_cells[x].cdr]
+#define FUNCTION(x) g_functions[g_cells[x].cdr]
 #define VALUE(x) g_cells[x].cdr
 #define VECTOR(x) g_cells[x].cdr
 
@@ -666,65 +666,28 @@ SCM
 call (SCM fn, SCM x)
 {
   puts ("call\n");
-#if __GNUC__
-  //fn=11
-  //function1
-  puts ("fn=");
-  puts (itoa(fn)); 
-  puts ("\n");
-  puts ("functiono");
-  puts (itoa(g_cells[fn].cdr));
-  puts ("\n");
-#endif
-  if (fn != 11) {
-    puts("FN != 11\n");
-    return 11;
-  }
-  if (g_cells[11].cdr != 1) {
-    puts("fn.cdr != 11\n");
-    return 11;
-  }
-  
   if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
       && x != cell_nil && TYPE (CAR (x)) == VALUES)
     x = cons (CADAR (x), CDR (x));
-  puts ("00\n");
   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
       && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
-  //struct function* f = &FUNCTION (fn);
-  puts ("01\n");
-  switch (2)///FIXME FUNCTION (fn).arity)
+  switch (FUNCTION (fn).arity)
     {
     // case 0: return FUNCTION (fn).function0 ();
     // case 1: return FUNCTION (fn).function1 (car (x));
     // case 2: return FUNCTION (fn).function2 (car (x), cadr (x));
     // case 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x)));
     // case -1: return FUNCTION (fn).functionn (x);
-    case 0: {puts("02.0\n");return (FUNCTION (fn).function) ();}
-    case 1: {puts("03.1\n");return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));}
-#if 0
-      //__GNUC__
-    case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));}
-#else
-    case 2: {
-      puts ("04.2\n");
-      SCM p1 = car (x);
-      SCM p2 = cdr (x);
-      p2 = car (p2);
-      //return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (p1, p2);
-      int (*functionx) (int,int) = (SCM(*)(SCM,SCM))FUNCTION (fn).function;
-      //return ((SCM(*)(SCM,SCM))(*FUNCTION (fn).function)) (p1, p2);
-      //return ((SCM(*)(SCM,SCM))(*functionx)) (p1, p2);
-      SCM p3;
-      //p3 = 0x44;
-      puts ("05\n");
-      return cons (p1, p2);
-      return (*functionx) (p1, p2);
-    }
+    case 0: {return (FUNCTION (fn).function) ();}
+    case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));}
+      //case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));}
+    case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), car (cdr (x)));}
+    case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));}
+#if __GNUC__
+      // FIXME GNUC
+    case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
 #endif
-    case 3: {puts("05.3\n");return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));}
-      //case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
     default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
     }
 
@@ -988,40 +951,22 @@ mes_builtins (SCM a)
 #else
 
 scm_make_cell.cdr = g_function;
-functions[g_function++] = fun_make_cell;
+g_functions[g_function++] = fun_make_cell;
 cell_make_cell = g_free++;
-#if __GNUC__
- puts ("WOOOT=");
- puts (itoa (g_free));
- puts ("\n");
-  //FIXME GNUC
  g_cells[cell_make_cell] = scm_make_cell;
-#else
-g_cells[16] = scm_make_cell;
-#endif
  
 scm_cons.cdr = g_function;
-functions[g_function++] = fun_cons;
+g_functions[g_function++] = fun_cons;
 cell_cons = g_free++;
-#if __GNUC__
-  //FIXME GNUC
 g_cells[cell_cons] = scm_cons;
-#else
-g_cells[17] = scm_cons;
-#endif
  
 scm_car.cdr = g_function;
-functions[g_function++] = fun_car;
+g_functions[g_function++] = fun_car;
 cell_car = g_free++;
-#if __GNUC__
-  //FIXME GNUC
 g_cells[cell_car] = scm_car;
-#endif
  
-#if __GNUC__
-  //FIXME GNUC
 scm_cdr.cdr = g_function;
-functions[g_function++] = fun_cdr;
+g_functions[g_function++] = fun_cdr;
 cell_cdr = g_free++;
 g_cells[cell_cdr] = scm_cdr;
 
@@ -1040,7 +985,6 @@ g_cells[cell_cdr] = scm_cdr;
 // scm_cdr.string = cstring_to_list (scm_cdr.name);
 // g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
 // a = acons (make_symbol (scm_cdr.string), cell_cdr, a);
-#endif
 #endif
   return a;
 }
@@ -1050,19 +994,13 @@ bload_env (SCM a) ///((internal))
 {
   g_stdin = open ("module/mes/read-0.mo", 0);
 #if __GNUC__
+  //FIXME GNUC
   //g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");
 #endif
   char *p = (char*)g_cells;
-#if __GNUC__
-  //FIXME GNUC
   assert (getchar () == 'M');
   assert (getchar () == 'E');
   assert (getchar () == 'S');
-#else
-  getchar ();
-  getchar ();
-  getchar ();
-#endif
   g_stack = getchar () << 8;
   g_stack += getchar ();
   int c = getchar ();
@@ -1093,32 +1031,7 @@ fill ()
   TYPE (9) = 0x2d2d2d2d;
   CAR (9) = 0x2d2d2d2d;
   CDR (9) = 0x3e3e3e3e;
-#if 0
-  // (A(B))
-  TYPE (10) = PAIR;
-  CAR (10) = 11;
-  CDR (10) = 12;
-
-  TYPE (11) = CHAR;
-  CAR (11) = 0x58585858;
-  CDR (11) = 89;
-
-  TYPE (12) = PAIR;
-  CAR (12) = 13;
-  CDR (12) = 1;
-
-  TYPE (13) = CHAR;
-  CAR (13) = 0x58585858;
-  CDR (13) = 90;
 
-  TYPE (14) = 0x58585858;
-  CAR (14) = 0x58585858;
-  CDR (14) = 0x58585858;
-
-  TYPE (14) = 0x58585858;
-  CAR (14) = 0x58585858;
-  CDR (14) = 0x58585858;
-#else
   // (cons 0 1)
   TYPE (10) = PAIR;
   CAR (10) = 11;
@@ -1148,29 +1061,6 @@ fill ()
   CAR (15) = 0x58585858;
   CDR (15) = 1;
 
-  //g_stack@23
-  TYPE (19) = PAIR;
-  CAR (19) = 1;
-  CDR (19) = 1;
-
-  TYPE (20) = PAIR;
-  CAR (20) = 7;
-  CDR (20) = 19;
-
-  TYPE (21) = PAIR;
-  CAR (21) = 7;
-  CDR (21) = 20;
-
-  TYPE (22) = PAIR;
-  CAR (22) = 134;
-  CDR (22) = 21;
-
-  TYPE (23) = PAIR;
-  CAR (23) = 22;
-  CDR (23) = 137;
-
-#endif
-
   return 0;
 }
 
@@ -1267,32 +1157,17 @@ simple_bload_env (SCM a) ///((internal))
   puts ("\n");
 #endif
 
-#if 0
-  //__GNUC__
   assert (getchar () == 'M');
   assert (getchar () == 'E');
   assert (getchar () == 'S');
   puts (" *GOT MES*\n");
   g_stack = getchar () << 8;
   g_stack += getchar ();
+
+#if __GNUC__
   puts ("stack: ");
   puts (itoa (g_stack));
   puts ("\n");
-#else
-  c = getchar ();
-  putchar (c);
-  if (c != 'M') exit (10);
-  c = getchar ();
-  putchar (c);
-  if (c != 'E') exit (11);
-  c = getchar ();
-  putchar (c);
-  if (c != 'S') exit (12);
-  puts (" *GOT MES*\n");
-
-  // skip stack
-  getchar ();
-  getchar ();
 #endif
 
   c = getchar ();
@@ -1305,28 +1180,21 @@ simple_bload_env (SCM a) ///((internal))
 
   puts ("read done\n");
 
-  // g_free = (p-(char*)g_cells) / sizeof (struct scm);
-  c = p-(char*)g_cells;
-  exit (c);
-  
-  
-  
+  g_free = (p-(char*)g_cells) / sizeof (struct scm);
   
- if (g_free != 15) exit (33);
 if (g_free != 15) exit (33);
   
-  // puts ("Xg_free: ");
-  // puts (itoa (g_free));
-  // puts ("\n");
-
-
-  ///if (g_free != 19) return 33;
-  
-  // gc_peek_frame ();
-  // g_symbols = r1;
+#if 0
+  gc_peek_frame ();
+  g_symbols = r1;
+#else
   g_symbols = 1;
+#endif
   g_stdin = STDIN;
   r0 = mes_builtins (r0);
   
+  if (g_free != 19) exit (34);
+  
 #if __GNUC__
   puts ("cells read: ");
   puts (itoa (g_free));
@@ -1429,44 +1297,17 @@ main (int argc, char *argv[])
   if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
 #endif
 
-#if 1
-
 #if __GNUC__
   puts ("g_free=");
   puts (itoa(g_free));
   puts ("\n");
-#else
-  g_free = 19;
-
 #endif
 
-  //return cons (r0, cell_nil);
-
-  //FIXME
   push_cc (r2, cell_unspecified, r0, cell_unspecified);
-#if __GNUC__
-  for (int x=19; x<26 ;x++)
-    {
-      puts(itoa(x));
-      puts(": type=");
-      puts(itoa(g_cells[x].type));
-      puts(" car=");
-      puts(itoa(g_cells[x].car));
-      puts(" cdr=");
-      puts(itoa(g_cells[x].cdr));
-      puts("\n");
-    }
-#endif
-#else
-  g_stack = 23;
-  g_free = 24;
-  r1 = r2; //10: the-program
-  r2 = cell_unspecified;
-#endif
 
-  puts ("g_stack: ");
-  display_ (g_stack);
-  puts ("\n");
+  // puts ("g_stack: ");
+  // display_ (g_stack);
+  // puts ("\n");
 
 #if __GNUC__
 
index ffa78723b65dae5bfbe9839fdae95923c059cbbd..23b27dd0e19f59e2279636d124fcf3a960270aca 100644 (file)
@@ -336,7 +336,7 @@ SCM tmp_num;
 SCM tmp_num2;
 
 int ARENA_SIZE = 200;
-struct function functions[2];
+struct function g_functions[5];
 int g_function = 0;
 
 
@@ -393,10 +393,10 @@ SCM cell_cdr;
 #endif
 #define CONTINUATION(x) g_cells[x].cdr
 #if __GNUC__
-//#define FUNCTION(x) functions[g_cells[x].function]
+//#define FUNCTION(x) g_functions[g_cells[x].function]
 #endif
 
-#define FUNCTION(x) functions[g_cells[x].cdr]
+#define FUNCTION(x) g_functions[g_cells[x].cdr]
 #define VALUE(x) g_cells[x].cdr
 #define VECTOR(x) g_cells[x].cdr
 
@@ -701,19 +701,8 @@ eval_apply ()
   switch (TYPE (car (r1)))
     {
     case TFUNCTION: {
-      puts ("apply.function\n");
-      y = 0x22;
       //check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
-#if __GNUC__
       r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
-#else
-      //FIXME
-      x = car (r1);
-      y = cdr (r1);
-      r1 = call (x, y);
-#endif
-      puts ("after call\n");
-      y = 0x44;
       goto vm_return;
     }
 //     case CLOSURE:
@@ -993,11 +982,8 @@ eval_apply ()
 // #endif
 
  vm_return:
-  // FIXME
-  puts ("vm-return00\n");
   x = r1;
   gc_pop_frame ();
-  puts ("vm-return01\n");
   r1 = x;
   goto eval_apply;
 }
@@ -1006,65 +992,28 @@ SCM
 call (SCM fn, SCM x)
 {
   puts ("call\n");
-#if __GNUC__
-  //fn=11
-  //function1
-  puts ("fn=");
-  puts (itoa(fn)); 
-  puts ("\n");
-  puts ("function");
-  puts (itoa(g_cells[fn].cdr));
-  puts ("\n");
-#endif
-  if (fn != 11) {
-    puts("FN != 11\n");
-    return 11;
-  }
-  if (g_cells[11].cdr != 1) {
-    puts("fn.cdr != 11\n");
-    return 11;
-  }
-  
   if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
       && x != cell_nil && TYPE (CAR (x)) == VALUES)
     x = cons (CADAR (x), CDR (x));
-  puts ("00\n");
   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
       && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
-  //struct function* f = &FUNCTION (fn);
-  puts ("01\n");
-  switch (2)///FIXME FUNCTION (fn).arity)
+  switch (FUNCTION (fn).arity)
     {
     // case 0: return FUNCTION (fn).function0 ();
     // case 1: return FUNCTION (fn).function1 (car (x));
     // case 2: return FUNCTION (fn).function2 (car (x), cadr (x));
     // case 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x)));
     // case -1: return FUNCTION (fn).functionn (x);
-    case 0: {puts("02.0\n");return (FUNCTION (fn).function) ();}
-    case 1: {puts("03.1\n");return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));}
-#if 0
-      //__GNUC__
-    case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));}
-#else
-    case 2: {
-      puts ("04.2\n");
-      SCM p1 = car (x);
-      SCM p2 = cdr (x);
-      p2 = car (p2);
-      //return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (p1, p2);
-      int (*functionx) (int,int) = (SCM(*)(SCM,SCM))FUNCTION (fn).function;
-      //return ((SCM(*)(SCM,SCM))(*FUNCTION (fn).function)) (p1, p2);
-      //return ((SCM(*)(SCM,SCM))(*functionx)) (p1, p2);
-      SCM p3;
-      //p3 = 0x44;
-      puts ("05\n");
-      return cons (p1, p2);
-      return (*functionx) (p1, p2);
-    }
+    case 0: {return (FUNCTION (fn).function) ();}
+    case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));}
+      //case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));}
+    case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), car (cdr (x)));}
+    case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));}
+#if __GNUC__
+      // FIXME GNUC
+    case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
 #endif
-    case 3: {puts("05.3\n");return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));}
-      //case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
     default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
     }
 
@@ -1328,40 +1277,22 @@ mes_builtins (SCM a)
 #else
 
 scm_make_cell.cdr = g_function;
-functions[g_function++] = fun_make_cell;
+g_functions[g_function++] = fun_make_cell;
 cell_make_cell = g_free++;
-#if __GNUC__
- puts ("WOOOT=");
- puts (itoa (g_free));
- puts ("\n");
-  //FIXME GNUC
  g_cells[cell_make_cell] = scm_make_cell;
-#else
-g_cells[16] = scm_make_cell;
-#endif
  
 scm_cons.cdr = g_function;
-functions[g_function++] = fun_cons;
+g_functions[g_function++] = fun_cons;
 cell_cons = g_free++;
-#if __GNUC__
-  //FIXME GNUC
 g_cells[cell_cons] = scm_cons;
-#else
-g_cells[17] = scm_cons;
-#endif
  
 scm_car.cdr = g_function;
-functions[g_function++] = fun_car;
+g_functions[g_function++] = fun_car;
 cell_car = g_free++;
-#if __GNUC__
-  //FIXME GNUC
 g_cells[cell_car] = scm_car;
-#endif
  
-#if __GNUC__
-  //FIXME GNUC
 scm_cdr.cdr = g_function;
-functions[g_function++] = fun_cdr;
+g_functions[g_function++] = fun_cdr;
 cell_cdr = g_free++;
 g_cells[cell_cdr] = scm_cdr;
 
@@ -1380,7 +1311,6 @@ g_cells[cell_cdr] = scm_cdr;
 // scm_cdr.string = cstring_to_list (scm_cdr.name);
 // g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
 // a = acons (make_symbol (scm_cdr.string), cell_cdr, a);
-#endif
 #endif
   return a;
 }
@@ -1390,19 +1320,13 @@ bload_env (SCM a) ///((internal))
 {
   g_stdin = open ("module/mes/read-0.mo", 0);
 #if __GNUC__
+  //FIXME GNUC
   //g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");
 #endif
   char *p = (char*)g_cells;
-#if __GNUC__
-  //FIXME GNUC
   assert (getchar () == 'M');
   assert (getchar () == 'E');
   assert (getchar () == 'S');
-#else
-  getchar ();
-  getchar ();
-  getchar ();
-#endif
   g_stack = getchar () << 8;
   g_stack += getchar ();
   int c = getchar ();
@@ -1592,6 +1516,7 @@ simple_bload_env (SCM a) ///((internal))
 {
   puts ("reading: ");
   char *mo = "module/mes/hack-32.mo";
+  //char *mo = "cons-32.mo";
   puts (mo);
   puts ("\n");
   g_stdin = open (mo, 0);
@@ -1607,32 +1532,16 @@ simple_bload_env (SCM a) ///((internal))
   puts ("\n");
 #endif
 
-#if 0
-  //__GNUC__
   assert (getchar () == 'M');
   assert (getchar () == 'E');
   assert (getchar () == 'S');
   puts (" *GOT MES*\n");
   g_stack = getchar () << 8;
   g_stack += getchar ();
+#if __GNUC__
   puts ("stack: ");
   puts (itoa (g_stack));
   puts ("\n");
-#else
-  c = getchar ();
-  putchar (c);
-  if (c != 'M') exit (10);
-  c = getchar ();
-  putchar (c);
-  if (c != 'E') exit (11);
-  c = getchar ();
-  putchar (c);
-  if (c != 'S') exit (12);
-  puts (" *GOT MES*\n");
-
-  // skip stack
-  getchar ();
-  getchar ();
 #endif
 
   c = getchar ();
@@ -1646,11 +1555,19 @@ simple_bload_env (SCM a) ///((internal))
   puts ("read done\n");
 
   g_free = (p-(char*)g_cells) / sizeof (struct scm);
-  // gc_peek_frame ();
-  // g_symbols = r1;
+
+#if 0
+  gc_peek_frame ();
+  g_symbols = r1;
+#else
+  if (g_free != 15) exit (33);
   g_symbols = 1;
+  r2 = 10;
+#endif
   g_stdin = STDIN;
   r0 = mes_builtins (r0);
+
+  ///if (g_free != 19) exit (34);
   
 #if __GNUC__
   puts ("cells read: ");
@@ -1660,11 +1577,16 @@ simple_bload_env (SCM a) ///((internal))
   puts ("symbols: ");
   puts (itoa (g_symbols));
   puts ("\n");
+
+  puts ("r2: ");
+  puts (itoa (r2));
+  puts ("\n");
+
   // display_ (g_symbols);
   // puts ("\n");
 #endif
 
-  display_ (10);
+  display_ (r2);
   puts ("\n");
 
   fill ();
@@ -1754,28 +1676,7 @@ main (int argc, char *argv[])
   if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
 #endif
 
-#if 0
-  //FIXME
   push_cc (r2, cell_unspecified, r0, cell_unspecified);
-#if __GNUC__
-  for (int x=19; x<26 ;x++)
-    {
-      puts(itoa(x));
-      puts(": type=");
-      puts(itoa(g_cells[x].type));
-      puts(" car=");
-      puts(itoa(g_cells[x].car));
-      puts(" cdr=");
-      puts(itoa(g_cells[x].cdr));
-      puts("\n");
-    }
-#endif
-#else
-  g_stack = 23;
-  g_free = 24;
-  r1 = r2; //10: the-program
-  r2 = cell_unspecified;
-#endif
 
 #if __GNUC__
   display_ (g_stack);
index ac6628be865cd6a0bd8f1a96b566f5901d21630b..61c36014d3d2eddc7ad50b39a4a3125ae9fcdd53 100644 (file)
@@ -101,13 +101,13 @@ char *g_chars = arena;
 char buf[200];
 
 int foo () {puts ("t: foo\n"); return 0;};
-int bar () {puts ("t: bar\n"); return 0;};
+int bar (int i) {puts ("t: bar\n"); return 0;};
 struct function {
   int (*function) (void);
   int arity;
 };
 struct function g_fun = {&exit, 1};
-struct function g_foo = {&foo, 1};
+struct function g_foo = {&foo, 0};
 struct function g_bar = {&bar, 1};
 
 //void *functions[2];
@@ -123,6 +123,15 @@ int g_free = 3;
 SCM tmp;
 SCM tmp_num;
 
+int ARENA_SIZE = 200;
+#define TYPE(x) (g_cells[x].type)
+#define CAR(x) g_cells[x].car
+#define CDR(x) g_cells[x].cdr
+#define VALUE(x) g_cells[x].cdr
+
+struct scm scm_fun = {TFUNCTION,0,0};
+SCM cell_fun;
+
 #if 1
 
 int
@@ -225,15 +234,6 @@ math_test ()
   return read_test ();
 }
 
-int ARENA_SIZE = 200;
-#define TYPE(x) (g_cells[x].type)
-#define CAR(x) g_cells[x].car
-#define CDR(x) g_cells[x].cdr
-#define VALUE(x) g_cells[x].cdr
-
-struct scm scm_fun = {TFUNCTION,0,0};
-SCM cell_fun;
-
 SCM
 alloc (int n)
 {
@@ -319,25 +319,48 @@ struct_test ()
 
   int fn = 0;
   puts ("t: g_functions[g_cells[fn].cdr].arity\n");
-  if (!g_functions[g_cells[fn].cdr].arity) return 1;
+#if __GNUC__
+  //FIXME
+  if (g_functions[g_cells[fn].cdr].arity) return 1;
+#endif
+  if (g_functions[g_cells[fn].cdr].arity != 0) return 1;
 
   int (*functionx) (void) = 0;
   functionx = g_functions[0].function;
   puts ("t: *functionx == foo\n");
-  if (*functionx != foo) return 11;
+  if (functionx != foo) return 11;
 
   puts ("t: (*functionx) () == foo\n");
-  if ((*functionx) () != 0) return 12;
+  if ((functionx) () != 0) return 12;
+
+  puts ("t: g_functions[<foo>].arity\n");
+  if (g_functions[0].arity != 0) return 17;
 
   fn++;
-  g_functions[0] = g_bar;
-  if (g_cells[fn].cdr != 0) return 13;
+  g_functions[fn] = g_bar;
+  g_cells[fn].cdr = fn;
+  if (g_cells[fn].cdr != fn) return 13;
+
   puts ("t: g_functions[g_cells[fn].cdr].function\n");
   functionx = g_functions[g_cells[fn].cdr].function;
-  puts ("t: *functionx == bar\n");
-  if (*functionx != bar) return 15;
-  puts ("t: (*functionx) () == bar\n");
-  if ((*functionx) () != 0) return 16;
+
+  puts ("t: functionx == bar\n");
+  if (functionx != bar) return 15;
+
+  puts ("t: (*functiony) (1) == bar\n");
+#if __GNUC__
+  //FIXME
+  int (*functiony) (int) = 0;
+  functiony = g_functions[g_cells[fn].cdr].function;
+  if ((functiony) (1) != 0) return 16;
+#endif
+#if !__GNUC__
+  functionx = g_functions[g_cells[fn].cdr].function;
+  if ((functionx) (1) != 0) return 16;
+#endif
+
+  puts ("t: g_functions[<bar>].arity;");
+  if (g_functions[fn].arity != 1) return 18;
 
   scm_fun.cdr = g_function;
   g_functions[g_function++] = g_fun;
@@ -619,6 +642,9 @@ test (char *p)
 int
 main (int argc, char *argv[])
 {
+  // int fn = 0;
+  // g_functions[fn] = g_bar;
+  // if (g_functions[fn].arity != 1) return 1;
   char *p = "t.c\n";
   puts ("t.c\n");