From 98f64ae516a89002ea51a277a7f39dc697ae465e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 22 Mar 2017 06:39:24 +0100 Subject: [PATCH] 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 | 53 ++-- math.c | 53 ++-- mes.c | 298 ++++++++++++------- mlibc.c | 47 ++- module/language/c99/compiler.mes | 68 ++++- module/mes/as-i386.mes | 17 +- module/mes/as-i386.scm | 3 + module/mes/libc.mes | 81 +++++- module/mes/mini-0.mes | 476 ++++++++++++++++++++++++++++++- posix.c | 73 ++--- reader.c | 43 +-- scaffold/mini-mes.c | 302 +++++++++++++++++--- scaffold/t.c | 29 +- 13 files changed, 1245 insertions(+), 298 deletions(-) diff --git a/lib.c b/lib.c index 3c9f49c9..503d3ce4 100644 --- a/lib.c +++ b/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 -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 -list (SCM x) ///((arity . n)) -{ - return x; -} +//MINI_MES +// SCM +// length (SCM x) +// { +// int n = 0; +// while (x != cell_nil) +// { +// n++; +// if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1); +// x = cdr (x); +// } +// return MAKE_NUMBER (n); +// } SCM exit_ (SCM x) ///((name . "exit")) @@ -75,24 +70,24 @@ append (SCM x) ///((arity . n)) // return buf; // } -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 +// 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 -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 () { diff --git a/math.c b/math.c index 11917fa6..ee48bbce 100644 --- a/math.c +++ b/math.c @@ -18,33 +18,34 @@ * along with Mes. If not, see . */ -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; -} +//MINI_MES +// 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; -} +// SCM +// less_p (SCM x) ///((name . "<") (arity . n)) +// { +// int n = INT_MIN; +// while (x != cell_nil) +// { +// assert (TYPE (car (x)) == TNUMBER); +// if (VALUE (car (x)) <= n) return cell_f; +// n = VALUE (car (x)); +// x = cdr (x); +// } +// return cell_t; +// } SCM is_p (SCM x) ///((name . "=") (arity . n)) diff --git a/mes.c b/mes.c index 540053b1..880a02ba 100644 --- a/mes.c +++ b/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 ("\n"); - puts ("#\\"); + //fputs ("\n", stdout); + fputs ("#\\", stdout); putchar (VALUE (x)); break; } case TFUNCTION: { -#if __GNUC__ - puts ("#"); + fputs ("#", stdout); break; -#endif - //puts ("\n"); - if (VALUE (x) == 0) - puts ("make-cell"); - if (VALUE (x) == 1) - puts ("cons"); - if (VALUE (x) == 2) - puts ("car"); - if (VALUE (x) == 3) - puts ("cdr"); + } + case TMACRO: + { + fputs ("#", 1); break; } case TNUMBER: { - //puts ("\n"); -#if __GNUC__ - puts (itoa (VALUE (x))); -#else - int i; - i = VALUE (x); - i = i + 48; - putchar (i); -#endif + //fputs ("\n", stdout); + fputs (itoa (VALUE (x)), stdout); break; } case TPAIR: { - //puts ("\n"); - //if (cont != cell_f) puts "("); - puts ("("); + //fputs ("\n", stdout); + //if (cont != cell_f) fputs ("(", stdout); + 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 (" . "); -#else - int c; - c = CDR (x); - c = TYPE (c); - if (c != TPAIR) - puts (" . "); -#endif + fputs (" . ", stdout); display_ (CDR (x)); } - //if (cont != cell_f) puts (")"); - puts (")"); + //if (cont != cell_f) fputs (")", stdout); + fputs (")", stdout); break; } case TSPECIAL: - { - switch (x) - { - case 1: {puts ("()"); break;} - case 2: {puts ("#f"); break;} - case 3: {puts ("#t"); break;} - default: - { -#if __GNUC__ - puts (""); -#else - puts (""); -#endif - } - } - break; - } + case TSTRING: 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 (""); -#else - puts (""); -#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 ("\n"); -#if __GNUC__ - puts ("<"); - puts (itoa (TYPE (x))); - puts (":"); - puts (itoa (x)); - puts (">"); -#else - puts ("_"); -#endif + //fputs ("\n", stdout); + fputs ("<", stdout); + fputs (itoa (TYPE (x)), stdout); + fputs (":", stdout); + fputs (itoa (x), stdout); + fputs (">", stdout); 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); - fputs ("", stderr); + ///stderr_ (r1); + display_ (r1); + fputs ("", stdout); gc (g_stack); #if __GNUC__ if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free); diff --git a/mlibc.c b/mlibc.c index 5d437d77..9fc0c519 100644 --- a/mlibc.c +++ b/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); - if (r < 1) return -1; - int i = 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; } +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 -assert_fail (char* s) +int +isdigit (char c) { - eputs ("assert fail: "); - eputs (s); - eputs ("\n"); - *((int*)0) = 0; + return (c>='0') && (c<='9'); } - -#define assert(x) ((x) ? (void)0 : assert_fail (#x)) #endif diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index 63b3154f..54eb31c5 100644 --- a/module/language/c99/compiler.mes +++ b/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* ((locals (add-local locals name type 0)) - (info (clone info #:locals locals)) - (value (- (cstring->number value)))) - (clone info #:text - (append text - ((value->ident info) name value))))) + (let ((value (- (cstring->number value)))) + (if (.function info) + (let* ((locals (add-local locals name type 0)) + (info (clone info #:locals locals))) + (clone info #:text + (append text + ((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))) diff --git a/module/mes/as-i386.mes b/module/mes/as-i386.mes index f9c483fa..7343614b 100644 --- a/module/mes/as-i386.mes +++ b/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 + `(#x76 ,(if (>= n 0) n (- n 2)))) ; jbe (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 +(define (i386:Xjump-cz n) + (or n urg:Xjump-cz) + `(#x0f #x86 ,@(int->bv32 n))) ; jbe + +(define (i386:Xjump-ncz n) + (or n urg:Xjump-ncz) + `(#x0f #x87 ,@(int->bv32 n))) ; ja + (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 + `(#x74 ,(if (>= n 0) n (- n 2)))) ; jz (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 + `(#x75 ,(if (>= n 0) n (- n 2)))) ; jnz (define (i386:test-jump-z n) (when (or (> n #x80) (< n #x-80)) diff --git a/module/mes/as-i386.scm b/module/mes/as-i386.scm index 1e38b119..fe0a008f 100644 --- a/module/mes/as-i386.scm +++ b/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 diff --git a/module/mes/libc.mes b/module/mes/libc.mes index 7735f307..531d4b8f 100644 --- a/module/mes/libc.mes +++ b/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 assert_fail +(define isdigit (let* ((ast (with-input-from-string " -void -assert_fail (char* s) +int +isdigit (char c) { - eputs (\"assert fail: \"); - eputs (s); - eputs (\"\n\"); - //*((int*)0) = 0; - char *fail = s; - fail = 0; - *fail = 0; + //return (c>='0') && (c<='9'); + if (c>='0' && c<='9') return 1; + return 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)) diff --git a/module/mes/mini-0.mes b/module/mes/mini-0.mes index 3844b8e3..887b92d4 100644 --- a/module/mes/mini-0.mes +++ b/module/mes/mini-0.mes @@ -1,7 +1,471 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017 Jan Nieuwenhuizen +;;; +;;; 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 . + +;;; 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 67)) - (write-byte (make-cell 0 0 10)) - #f - ) + + (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 10)) + + ((lambda (a+ a) + + ;; (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 ) 5) (list)) (current-module)) + + ;; (core:display (quote cm:)) + ;; (core:display ) + ;; (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 ) 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) ))) + (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 (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 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 0) + + ;; (core:display ) + ;; (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 4) + (define 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 lst 0)) + + (define (integer->char x) + (make-cell 0 x)) + + (define (symbol->keyword s) + (make-cell (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) + +) diff --git a/posix.c b/posix.c index f708b9ef..4e47b855 100644 --- a/posix.c +++ b/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 -peek_byte () -{ - return MAKE_NUMBER (peekchar ()); -} +// MINI_MES +// int +// getchar () +// { +// return getc (g_stdin); +// } -SCM -read_byte () -{ - return MAKE_NUMBER (getchar ()); -} +// int +// ungetchar (int c) +// { +// return ungetc (c, g_stdin); +// } -SCM -unread_byte (SCM i) -{ - ungetchar (VALUE (i)); - return i; -} +// 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 force_output (SCM p) ///((arity . n)) diff --git a/reader.c b/reader.c index ed55709f..842f3f6b 100644 --- a/reader.c +++ b/reader.c @@ -86,25 +86,26 @@ read_env (SCM a) return read_word (getchar (), cell_nil, a); } -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); - } +//MINI_MES +// 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 x = lookup_symbol_ (s); +// return x ? x : make_symbol_ (s); +// } diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c index a406cb3b..d8556cf9 100644 --- a/scaffold/mini-mes.c +++ b/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; -char arena[1200000]; +// int ARENA_SIZE = 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 ("#"); + break; + } case TNUMBER: { //puts ("\n"); @@ -991,25 +1188,19 @@ display_ (SCM x) break; } case TSPECIAL: - { - switch (x) - { - case 1: {puts ("()"); break;} - case 2: {puts ("#f"); break;} - case 3: {puts ("#t"); break;} - default: - { - puts (""); - } - } - break; - } +#if __NYACC__ + // FIXME + {} +#endif + case TSTRING: +#if __NYACC__ + // FIXME + {} +#endif 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_prefix, MAKE_STRING (cstring_to_list (PREFIX)), 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_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[]) { diff --git a/scaffold/t.c b/scaffold/t.c index 8c87ff31..67843c68 100644 --- a/scaffold/t.c +++ b/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 < 0x44) goto ok3; + if (one < 2) 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;