From 78e70f9024168785ad264ef2dd354c87c2f32810 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Thu, 2 Mar 2017 20:26:13 +0100 Subject: [PATCH] mescc: Support struct assignment. * 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 | 2 +- mes.c | 4 +- module/language/c99/compiler.mes | 142 ++++++++++++++------ module/mes/libc-i386.mes | 10 ++ module/mes/libc-i386.scm | 4 + scaffold/cons-mes.c | 221 +++++-------------------------- scaffold/mini-mes.c | 169 +++++------------------ scaffold/t.c | 66 ++++++--- 8 files changed, 230 insertions(+), 388 deletions(-) diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index 28529845..dda015e2 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -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 51313500..cc53d4a1 100644 --- 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 diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index cbaaf3a1..89a784e6 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -997,7 +997,9 @@ (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) @@ -1625,7 +1627,7 @@ #: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 '())) @@ -1784,7 +1786,7 @@ ((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) @@ -1793,84 +1795,142 @@ (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 ;; diff --git a/module/mes/libc-i386.mes b/module/mes/libc-i386.mes index 7fb2f818..f6ae7c54 100644 --- a/module/mes/libc-i386.mes +++ b/module/mes/libc-i386.mes @@ -232,6 +232,16 @@ (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) diff --git a/module/mes/libc-i386.scm b/module/mes/libc-i386.scm index 5e2a929f..3f2762b7 100644 --- a/module/mes/libc-i386.scm +++ b/module/mes/libc-i386.scm @@ -127,6 +127,10 @@ i386:XXjump + i386:accu+n + i386:base+n + i386:base-address->accu-address + ;; libc i386:exit i386:open diff --git a/scaffold/cons-mes.c b/scaffold/cons-mes.c index 77c89294..290617c9 100644 --- a/scaffold/cons-mes.c +++ b/scaffold/cons-mes.c @@ -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__ diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c index ffa78723..23b27dd0 100644 --- a/scaffold/mini-mes.c +++ b/scaffold/mini-mes.c @@ -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); diff --git a/scaffold/t.c b/scaffold/t.c index ac6628be..61c36014 100644 --- a/scaffold/t.c +++ b/scaffold/t.c @@ -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[].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[].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");