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

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

Browse source 
* 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.
This commit is contained in:
Jan Nieuwenhuizen 2017-03-22 06:39:24 +01:00
parent 240f2814f4
commit 98f64ae516
13 changed files with 1245 additions and 298 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

53
lib.c
View file

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

53
math.c
View file

@ -18,33 +18,34 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
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))

298
mes.c
View file

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

47
mlibc.c
View file

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

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

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

17
module/mes/as-i386.mes
View file

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

3
module/mes/as-i386.scm
View file

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

81
module/mes/libc.mes
View file

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

476
module/mes/mini-0.mes
View file

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

73
posix.c
View file

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

43
reader.c
View file

@ -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);
// }

302
scaffold/mini-mes.c
View file

@ -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 ("#<macro ");
display_ (cdr (x));
puts (">");
break;
}
case TNUMBER:
{
//puts ("<number>\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 ("<x:");
puts (itoa (x));
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[])
{

29
scaffold/t.c
View file

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