artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: Support struct assignment.

Browse source 
* 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:
This commit is contained in:
Jan Nieuwenhuizen 2017-03-02 20:26:13 +01:00
parent 08ea0da745
commit 78e70f9024
8 changed files with 230 additions and 388 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
build-aux/mes-snarf.scm
View file

@ -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))))

4
mes.c
View file

@ -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

142
module/language/c99/compiler.mes
View file

@ -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
;;

10
module/mes/libc-i386.mes
View file

@ -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)

4
module/mes/libc-i386.scm
View file

@ -127,6 +127,10 @@
i386:XXjump
i386:accu+n
i386:base+n
i386:base-address->accu-address
;; libc
i386:exit
i386:open

221
scaffold/cons-mes.c
View 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__

169
scaffold/mini-mes.c
View 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);

66
scaffold/t.c
View 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");