* 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.
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"))
// 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));
return p+1;
}
-FILE *g_stdin;
+//FILE *g_stdin;
int
dump ()
{
* 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))
#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)
return CDR (x);
}
+SCM
+list (SCM x) ///((arity . n))
+{
+ return x;
+}
+
SCM
null_p (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)
{
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 ();
{
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;
}
&& (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
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);
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)
{
}
//\f 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))
return buf;
}
-#if __GNUC__
-char const* itoa(int);
-#endif
-
SCM
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;
}
}
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;
+}
+
+//\f MINI_MES+
SCM
make_vector (SCM n)
{
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);
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)
{
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)
{
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
(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))
(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))
(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 '()))
(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 '()))
;; 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))))))
(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)))
(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
(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))
(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))
i386:accu+value
i386:accu/base
i386:accu%base
+ i386:accu*base
i386:accu-base
i386:accu-shl
i386:base-sub
i386:Xjump
i386:Xjump
i386:Xjump-c
+ i386:Xjump-cz
i386:Xjump-nc
+ i386:Xjump-ncz
i386:Xjump-nz
i386:Xjump-z
(let* ((ast (with-input-from-string
"
int g_stdin;
+int ungetc_char = -1;
+
+#if 0
int
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)))
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:"
(list
strlen
getchar
+ assert_fail
+ ungetc
putchar
eputs
fputs
puts
strcmp
itoa
- assert_fail))
+ isdigit))
+;;; -*-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)
+
+)
// 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"))
{
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))
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);
+// }
#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
#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;
#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
return CDR(x);
}
+SCM
+list (SCM x) ///((arity . n))
+{
+ return x;
+}
+
SCM
null_p (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))
{
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)
{
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) ();}
{
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;
}
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;
}
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;
r1 = cdr (r1);
goto call_with_current_continuation;
}
- //default: check_apply (cell_f, car (r1));
+ default: check_apply (cell_f, car (r1));
}
}
case TSYMBOL:
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;
}
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;
&& (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
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);
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
//\f 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))
{
puts ("]>");
break;
}
+ case TMACRO:
+ {
+ puts ("#<macro ");
+ display_ (cdr (x));
+ puts (">");
+ break;
+ }
case TNUMBER:
{
//puts ("<number>\n");
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);
#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;
}
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[])
{
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;
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;
projects / mes.git / commitdiff