/* -*-comment-start: "//";comment-end:""-*- * 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 . */ #if __GNUC__ #include "mlibc.c" #endif #define assert(x) ((x) ? (void)0 : assert_fail (#x)) #if __MESC__ //void *g_malloc_base = 0; char *g_malloc_base = 0; // int ungetc_char = -1; // char ungetc_buf[2]; #endif #define MES_MINI 1 #define FIXED_PRIMITIVES 1 #if __GNUC__ #define FIXME_NYACC 1 #define __NYACC__ 0 #define NYACC_CAR #define NYACC_CDR #else #define __NYACC__ 1 #define NYACC_CAR nyacc_car #define NYACC_CDR nyacc_cdr #endif //int ARENA_SIZE = 4000000; int ARENA_SIZE = 1000000000; char *arena = 0; typedef int SCM; int g_debug = 0; int g_free = 0; SCM g_continuations = 0; SCM g_symbols = 0; SCM g_stack = 0; // a/env SCM r0 = 0; // param 1 SCM r1 = 0; // save 2+load/dump SCM r2 = 0; // continuation SCM r3 = 0; enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART}; struct scm { enum type_t type; SCM car; SCM cdr; }; struct function { int (*function) (void); int arity; char *name; }; //struct scm *g_cells = arena; int *foobar = 0; #if __GNUC__ struct scm *g_cells; #else struct scm *g_cells = foobar; #endif //FIXME //struct scm *g_news = 0; struct scm scm_nil = {TSPECIAL, "()",0}; struct scm scm_f = {TSPECIAL, "#f",0}; struct scm scm_t = {TSPECIAL, "#t",0}; struct scm scm_dot = {TSPECIAL, ".",0}; struct scm scm_arrow = {TSPECIAL, "=>",0}; struct scm scm_undefined = {TSPECIAL, "*undefined*",0}; struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0}; struct scm scm_closure = {TSPECIAL, "*closure*",0}; struct scm scm_circular = {TSPECIAL, "*circular*",0}; struct scm scm_begin = {TSPECIAL, "*begin*",0}; struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0}; struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0}; struct scm scm_symbol_begin = {TSYMBOL, "begin",0}; struct scm scm_symbol_if = {TSYMBOL, "if",0}; struct scm scm_symbol_quote = {TSYMBOL, "quote",0}; struct scm scm_symbol_set_x = {TSYMBOL, "set!",0}; struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0}; struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0}; struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0}; struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0}; struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0}; struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0}; struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0}; struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0}; struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0}; struct scm scm_symbol_write = {TSYMBOL, "write",0}; struct scm scm_symbol_display = {TSYMBOL, "display",0}; struct scm scm_symbol_throw = {TSYMBOL, "throw",0}; struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0}; struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0}; struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0}; struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0}; struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0}; struct scm scm_symbol_argv = {TSYMBOL, "%argv",0}; struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0}; struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0}; struct scm scm_symbol_car = {TSYMBOL, "car",0}; struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0}; struct scm scm_symbol_null_p = {TSYMBOL, "null?",0}; struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0}; struct scm scm_symbol_cons = {TSYMBOL, "cons",0}; struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0}; struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0}; struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0}; struct scm scm_vm_apply = {TSPECIAL, "core:apply",0}; struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0}; struct scm scm_vm_eval = {TSPECIAL, "core:eval",0}; //FIXED_PRIMITIVES struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0}; struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0}; struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0}; struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0}; struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0}; struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0}; struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0}; struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0}; struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0}; struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0}; struct scm scm_vm_begin2 = {TSPECIAL, "*vm-begin2*",0}; struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0}; struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0}; struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0}; struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0}; struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0}; struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0}; struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0}; struct scm scm_test = {TSYMBOL, "test",0}; #include "mini-mes.symbols.h" SCM tmp; SCM tmp_num; SCM tmp_num2; struct function g_functions[200]; int g_function = 0; // #include "lib.h" // #include "math.h" #include "mini-mes.h" // #include "posix.h" // #include "reader.h" #define TYPE(x) (g_cells[x].type) #define CAR(x) g_cells[x].car #define LENGTH(x) g_cells[x].car #define STRING(x) g_cells[x].car #define CDR(x) g_cells[x].cdr #define CLOSURE(x) g_cells[x].cdr #define CONTINUATION(x) g_cells[x].cdr #define FUNCTION(x) g_functions[g_cells[x].cdr] #define MACRO(x) g_cells[x].cdr #define VALUE(x) g_cells[x].cdr #define VECTOR(x) g_cells[x].cdr #define MAKE_CHAR(n) make_cell (tmp_num_ (TCHAR), 0, tmp_num2_ (n)) #define MAKE_CONTINUATION(n) make_cell (tmp_num_ (TCONTINUATION), n, g_stack) #define MAKE_NUMBER(n) make_cell (tmp_num_ (TNUMBER), 0, tmp_num2_ (n)) //#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0) #define CAAR(x) CAR (CAR (x)) #define CDAR(x) CDR (CAR (x)) #define CADAR(x) CAR (CDR (CAR (x))) #define CADDR(x) CAR (CDR (CDR (x))) // #define CDDDR(x) CDR (CDR (CDR (x))) #define CDADAR(x) CAR (CDR (CAR (CDR (x)))) #define CADR(x) CAR (CDR (x)) #define MAKE_STRING(x) make_cell (tmp_num_ (TSTRING), x, 0) SCM alloc (int n) { #if 1 //__GNUC__ assert (g_free + n < ARENA_SIZE); #endif SCM x = g_free; g_free += n; return x; } #define DEBUG 0 SCM make_cell (SCM type, SCM car, SCM cdr) { SCM x = alloc (1); #if __GNUC__ assert (TYPE (type) == TNUMBER); #endif TYPE (x) = VALUE (type); if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) { if (car) CAR (x) = CAR (car); if (cdr) CDR(x) = CDR(cdr); } else if (VALUE (type) == TFUNCTION) { if (car) CAR (x) = car; if (cdr) CDR(x) = CDR(cdr); } else { CAR (x) = car; CDR(x) = cdr; } return x; } SCM tmp_num_ (int x) { VALUE (tmp_num) = x; return tmp_num; } SCM tmp_num2_ (int x) { VALUE (tmp_num2) = x; return tmp_num2; } SCM cons (SCM x, SCM y) { VALUE (tmp_num) = TPAIR; return make_cell (tmp_num, x, y); } SCM car (SCM x) { #if MES_MINI //Nyacc //assert ("!car"); #else if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car)); #endif return CAR (x); } SCM cdr (SCM x) { #if MES_MINI //Nyacc //assert ("!cdr"); #else if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr)); #endif return CDR(x); } SCM list (SCM x) ///((arity . n)) { return x; } SCM null_p (SCM x) { return x == cell_nil ? cell_t : cell_f; } SCM eq_p (SCM x, SCM y) { return (x == y || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD && STRING (x) == STRING (y))) || (TYPE (x) == TCHAR && TYPE (y) == TCHAR && VALUE (x) == VALUE (y)) || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER && VALUE (x) == VALUE (y))) ? cell_t : cell_f; } SCM type_ (SCM x) { return MAKE_NUMBER (TYPE (x)); } SCM car_ (SCM x) { return (TYPE (x) != TCONTINUATION && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird || TYPE (CAR (x)) == TREF || TYPE (CAR (x)) == TSPECIAL || TYPE (CAR (x)) == TSYMBOL || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x)); } SCM cdr_ (SCM x) { return (TYPE (CDR (x)) == TPAIR || TYPE (CDR (x)) == TREF || TYPE (CAR (x)) == TSPECIAL || TYPE (CDR (x)) == TSYMBOL || 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); eputs ("unbound variable: "); display_ (x); eputs ("\n"); exit (33); return e; } SCM cstring_to_list (char const* s) { char *x = s; SCM p = cell_nil; int i = strlen (s); while (i--) { p = cons (MAKE_CHAR (s[i]), p); x++; } return p; } 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)) { SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil)))); g_stack = cons (frame, g_stack); 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 (x == cell_nil) return y; #if __GNUC__ assert (TYPE (x) == TPAIR); #endif return cons (car (x), append2 (cdr (x), y)); } SCM pairlis (SCM x, SCM y, SCM a) { if (x == cell_nil) return a; if (TYPE (x) != TPAIR) return cons (cons (x, y), a); return cons (cons (car (x), car (y)), pairlis (cdr (x), cdr (y), a)); } SCM display_ (SCM); SCM call (SCM fn, SCM x) { if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1) && x != cell_nil && TYPE (CAR (x)) == TVALUES) x = cons (CADAR (x), CDR (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) ();} case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));} case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));} case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));} case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);} } return cell_unspecified; } SCM assq (SCM x, SCM a) { //FIXME: eq_p //while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a); while (a != cell_nil && x != CAAR (a)) a = CDR (a); return a != cell_nil ? car (a) : cell_f; } SCM assq_ref_env (SCM x, SCM a) { x = assq (x, a); if (x == cell_f) return cell_undefined; return cdr (x); } SCM set_car_x (SCM x, SCM e) { #if __GNUC__ assert (TYPE (x) == TPAIR); #endif CAR (x) = e; return cell_unspecified; } SCM set_cdr_x (SCM x, SCM e) { //if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x)); CDR (x) = e; return cell_unspecified; } SCM set_env_x (SCM x, SCM e, SCM a) { SCM p = assert_defined (x, assq (x, a)); //if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x)); return set_cdr_x (p, e); } SCM call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal)) { SCM cl = cons (cons (cell_closure, x), x); cl = cons (cons (cell_closure, x), x); r1 = e; r0 = cl; return cell_unspecified; } SCM make_closure (SCM args, SCM body, SCM a) { return make_cell (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body))); } SCM 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; } SCM push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal)) { SCM x = r3; r3 = c; r2 = p2; gc_push_frame (); r1 = p1; r0 = a; r3 = x; return cell_unspecified; } SCM caar (SCM x) {return car (car (x));} SCM cadr (SCM x) {return car (cdr (x));} SCM cdar (SCM x) {return cdr (car (x));} SCM cddr (SCM x) {return cdr (cdr (x));} SCM gc_pop_frame (); //((internal)) SCM eval_apply () { eval_apply: // if (g_free + GC_SAFETY > ARENA_SIZE) // gc_pop_frame (gc (gc_push_frame ())); switch (r3) { case cell_vm_evlis: goto evlis; case cell_vm_evlis2: goto evlis2; case cell_vm_evlis3: goto evlis3; case cell_vm_apply: goto apply; case cell_vm_apply2: goto apply2; case cell_vm_eval: goto eval; #if FIXED_PRIMITIVES case cell_vm_eval_car: goto eval_car; case cell_vm_eval_cdr: goto eval_cdr; case cell_vm_eval_cons: goto eval_cons; case cell_vm_eval_null_p: goto eval_null_p; #endif case cell_vm_eval_set_x: goto eval_set_x; case cell_vm_eval_macro: goto eval_macro; case cell_vm_eval2: goto eval2; case cell_vm_macro_expand: goto macro_expand; case cell_vm_begin: goto begin; case cell_vm_begin_read_input_file: goto begin_read_input_file; case cell_vm_begin2: goto begin2; case cell_vm_if: goto vm_if; case cell_vm_if_expr: goto if_expr; case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2; case cell_vm_call_with_values2: goto call_with_values2; case cell_vm_return: goto vm_return; case cell_unspecified: return r1; default: assert (0); } SCM x = cell_nil; SCM y = cell_nil; evlis: if (r1 == cell_nil) goto vm_return; if (TYPE (r1) != TPAIR) goto eval; push_cc (car (r1), r1, r0, cell_vm_evlis2); goto eval; evlis2: push_cc (cdr (r2), r1, r0, cell_vm_evlis3); goto evlis; evlis3: r1 = cons (r2, r1); goto vm_return; apply: switch (TYPE (car (r1))) { case TFUNCTION: { 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; } case TCLOSURE: { SCM cl = CLOSURE (car (r1)); SCM formals = cadr (cl); SCM body = cddr (cl); SCM aa = cdar (cl); aa = cdr (aa); check_formals (car (r1), formals, cdr (r1)); SCM p = pairlis (formals, cdr (r1), aa); call_lambda (body, p, aa, r0); goto begin; } case TCONTINUATION: { x = r1; g_stack = CONTINUATION (CAR (r1)); gc_pop_frame (); r1 = cadr (x); goto eval_apply; } case TSPECIAL: { switch (car (r1)) { case cell_vm_apply: { push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return); goto apply; } case cell_vm_eval: { push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return); goto eval; } case cell_call_with_current_continuation: { r1 = cdr (r1); goto call_with_current_continuation; } default: check_apply (cell_f, car (r1)); } } case TSYMBOL: { if (car (r1) == cell_symbol_call_with_values) { r1 = cdr (r1); goto call_with_values; } if (car (r1) == cell_symbol_current_module) { r1 = r0; goto vm_return; } break; } case TPAIR: { switch (caar (r1)) { case cell_symbol_lambda: { SCM formals = cadr (car (r1)); SCM body = cddr (car (r1)); SCM p = pairlis (formals, cdr (r1), r0); 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)); r1 = cons (r1, cdr (r2)); goto apply; eval: switch (TYPE (r1)) { case TPAIR: { switch (car (r1)) { #if FIXED_PRIMITIVES case cell_symbol_car: { push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval; eval_car: x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply; } case cell_symbol_cdr: { push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval; eval_cdr: x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply; } case cell_symbol_cons: { push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis; eval_cons: x = r1; gc_pop_frame (); r1 = cons (CAR (x), CADR (x)); goto eval_apply; } case cell_symbol_null_p: { push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p); goto eval; eval_null_p: x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply; } #endif // FIXED_PRIMITIVES case cell_symbol_quote: { x = r1; gc_pop_frame (); r1 = cadr (x); goto eval_apply; } case cell_symbol_begin: goto begin; case cell_symbol_lambda: { r1 = make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0)); goto vm_return; } case cell_symbol_if: {r1=cdr (r1); goto vm_if;} case cell_symbol_set_x: { push_cc (car (cddr (r1)), r1, r0, cell_vm_eval_set_x); goto eval; eval_set_x: x = r2; r1 = set_env_x (cadr (x), r1, r0); goto vm_return; } case cell_vm_macro_expand: { push_cc (cadr (r1), r1, r0, cell_vm_return); goto macro_expand; } default: { push_cc (r1, r1, r0, cell_vm_eval_macro); goto macro_expand; eval_macro: x = r2; if (r1 != r2) { if (TYPE (r1) == TPAIR) { set_cdr_x (r2, cdr (r1)); set_car_x (r2, car (r1)); } goto eval; } push_cc (CDR (r1), r1, r0, cell_vm_eval2); goto evlis; eval2: r1 = cons (car (r2), r1); goto apply; } } } case TSYMBOL: { r1 = assert_defined (r1, assq_ref_env (r1, r0)); goto vm_return; } default: {goto vm_return;} } SCM macro; SCM expanders; macro_expand: if (TYPE (r1) == TPAIR && (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 && TYPE (CAR (r1)) == TSYMBOL && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined) && ((macro = assq (CAR (r1), expanders)) != cell_f)) { SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0); if (sc_expand != cell_undefined && sc_expand != cell_f) { r1 = cons (sc_expand, cons (r1, cell_nil)); goto apply; } } goto vm_return; begin: x = cell_unspecified; while (r1 != cell_nil) { if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR) { if (caar (r1) == cell_symbol_begin) r1 = append2 (cdar (r1), cdr (r1)); else if (caar (r1) == cell_symbol_primitive_load) { push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file); goto apply; begin_read_input_file: r1 = append2 (r1, cdr (r2)); } } 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); goto eval; begin2: x = r1; r1 = CDR (r2); } r1 = x; goto vm_return; vm_if: push_cc (car (r1), r1, r0, cell_vm_if_expr); goto eval; if_expr: x = r1; r1 = r2; if (x != cell_f) { r1 = cadr (r1); goto eval; } if (cddr (r1) != cell_nil) { r1 = car (cddr (r1)); goto eval; } r1 = cell_unspecified; goto vm_return; call_with_current_continuation: gc_push_frame (); #if __GNUC__ // FIXME GCC x = MAKE_CONTINUATION (g_continuations++); #else x = MAKE_CONTINUATION (g_continuations); g_continuations++; #endif gc_pop_frame (); push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2); goto apply; call_with_current_continuation2: CONTINUATION (r2) = g_stack; goto vm_return; call_with_values: push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2); goto apply; call_with_values2: if (TYPE (r1) == TVALUES) r1 = CDR (r1); r1 = cons (cadr (r2), r1); goto apply; vm_return: x = r1; gc_pop_frame (); r1 = x; goto eval_apply; } SCM gc_peek_frame () ///((internal)) { SCM frame = car (g_stack); r1 = car (frame); r2 = cadr (frame); r3 = car (cddr (frame)); r0 = cadr (cddr (frame)); return frame; } SCM gc_pop_frame () ///((internal)) { SCM frame = gc_peek_frame (g_stack); g_stack = cdr (g_stack); return frame; } SCM mes_g_stack (SCM a) ///((internal)) { r0 = a; r1 = MAKE_CHAR (0); r2 = MAKE_CHAR (0); r3 = MAKE_CHAR (0); g_stack = cons (cell_nil, cell_nil); return r0; } // Environment setup SCM make_tmps (struct scm* cells) { tmp = g_free++; cells[tmp].type = TCHAR; tmp_num = g_free++; cells[tmp_num].type = TNUMBER; tmp_num2 = g_free++; cells[tmp_num2].type = TNUMBER; return 0; } SCM make_symbol_ (SCM s) { VALUE (tmp_num) = TSYMBOL; SCM x = make_cell (tmp_num, s, 0); g_symbols = cons (x, g_symbols); return x; } SCM list_of_char_equal_p (SCM a, SCM b) { while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) { #if __GNUC__ assert (TYPE (car (a)) == TCHAR); assert (TYPE (car (b)) == TCHAR); #endif a = cdr (a); b = cdr (b); } return (a == cell_nil && b == cell_nil) ? cell_t : cell_f; } SCM lookup_symbol_ (SCM s) { SCM x = g_symbols; 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) goto dun; x = cdr (x); } dun: if (x) x = car (x); return x; } SCM make_symbol (SCM s) { 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 acons (SCM key, SCM value, SCM alist) { return cons (cons (key, value), alist); } // Posix 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)) { SCM c = car (x); SCM p = cdr (x); int fd = 1; if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); //FILE *f = fd == 1 ? stdout : stderr; #if __GNUC__ assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR); #endif // fputc (VALUE (c), f); char cc = VALUE (c); write (1, (char*)&cc, fd); return c; } char string_to_cstring_buf[1024]; char const* string_to_cstring (SCM s) { //static char buf[1024]; //char *p = buf; char *p = string_to_cstring_buf; s = STRING(s); while (s != cell_nil) { *p++ = VALUE (car (s)); s = cdr (s); } *p = 0; //return buf; return string_to_cstring_buf; } int g_depth; SCM display_helper (SCM x, int cont, char* sep) { puts (sep); if (g_depth == 0) return cell_unspecified; //FIXME: //g_depth--; g_depth = g_depth - 1; // eputs ("\n"); switch (TYPE (x)) { case TCHAR: { //puts ("\n"); puts ("#\\"); putchar (VALUE (x)); break; } case TFUNCTION: { puts ("#"); break; } case TMACRO: { puts ("#"); break; } case TNUMBER: { //puts ("\n"); puts (itoa (VALUE (x))); break; } case TPAIR: { if (!cont) puts ("("); if (x && x != cell_nil) display_ (CAR (x)); if (CDR (x) && TYPE (CDR (x)) == TPAIR) display_helper (CDR (x), 1, " "); else if (CDR (x) && CDR (x) != cell_nil) { if (TYPE (CDR (x)) != TPAIR) puts (" . "); display_ (CDR (x)); } if (!cont) puts (")"); break; } case TSPECIAL: #if __NYACC__ // FIXME //{} { SCM t = CAR (x); while (t && t != cell_nil) { putchar (VALUE (CAR (t))); t = CDR (t); } break; } #endif case TSTRING: #if __NYACC__ // FIXME //{} { SCM t = CAR (x); while (t && t != cell_nil) { putchar (VALUE (CAR (t))); t = CDR (t); } break; } #endif case TSYMBOL: { SCM t = CAR (x); while (t && t != cell_nil) { putchar (VALUE (CAR (t))); t = CDR (t); } break; } default: { //puts ("\n"); puts ("<"); puts (itoa (TYPE (x))); puts (":"); puts (itoa (x)); puts (">"); break; } } return 0; } SCM display_ (SCM x) { g_depth = 5; return display_helper (x, 0, ""); } SCM stderr_ (SCM x) { SCM write; if (TYPE (x) == TSTRING) eputs (string_to_cstring (x)); #if __GNUC__ else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined) apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0); #endif else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL) eputs (string_to_cstring (x)); else if (TYPE (x) == TNUMBER) eputs (itoa (VALUE (x))); else eputs ("core:stderr: display undefined\n"); return cell_unspecified; } SCM getenv_ (SCM s) ///((name . "getenv")) { #if 0 char *p = getenv (string_to_cstring (s)); return p ? MAKE_STRING (cstring_to_list (p)) : cell_f; #else return cell_t; #endif } SCM open_input_file (SCM file_name) { return MAKE_NUMBER (open (string_to_cstring (file_name), O_RDONLY)); // char *s = string_to_cstring (file_name); // int x = open (s, 0); // return MAKE_NUMBER (x); } SCM current_input_port () { return MAKE_NUMBER (g_stdin); } SCM set_current_input_port (SCM port) { g_stdin = VALUE (port) ? VALUE (port) : STDIN; return current_input_port (); } SCM force_output (SCM p) ///((arity . n)) { #if 0 //FIXME int fd = 1; if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p)); FILE *f = fd == 1 ? stdout : stderr; fflush (f); #endif return cell_unspecified; } // Math 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 __MESC__ //FIXME __GNUC__ if (n == INT_MIN); else #endif 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)) { if (x == cell_nil) return cell_t; assert (TYPE (car (x)) == TNUMBER); int n = VALUE (car (x)); x = cdr (x); while (x != cell_nil) { if (VALUE (car (x)) != n) return cell_f; x = cdr (x); } return cell_t; } SCM minus (SCM x) ///((name . "-") (arity . n)) { SCM a = car (x); assert (TYPE (a) == TNUMBER); int n = VALUE (a); x = cdr (x); if (x == cell_nil) n = -n; while (x != cell_nil) { assert (TYPE (car (x)) == TNUMBER); #if __GNUC__ n -= VALUE (car (x)); #else n = n - VALUE (car (x)); #endif x = cdr (x); } return MAKE_NUMBER (n); } SCM plus (SCM x) ///((name . "+") (arity . n)) { int n = 0; while (x != cell_nil) { assert (TYPE (car (x)) == TNUMBER); #if __GNUC__ n += VALUE (car (x)); #else n = n + VALUE (car (x)); #endif x = cdr (x); } return MAKE_NUMBER (n); } SCM divide (SCM x) ///((name . "/") (arity . n)) { int n = 1; if (x != cell_nil) { assert (TYPE (car (x)) == TNUMBER); n = VALUE (car (x)); x = cdr (x); } while (x != cell_nil) { assert (TYPE (car (x)) == TNUMBER); #if __GNUC__ n /= VALUE (car (x)); #else n = n / VALUE (car (x)); #endif x = cdr (x); } return MAKE_NUMBER (n); } SCM modulo (SCM a, SCM b) { assert (TYPE (a) == TNUMBER); assert (TYPE (b) == TNUMBER); int x = VALUE (a); while (x < 0) x += VALUE (b); return MAKE_NUMBER (x % VALUE (b)); } SCM multiply (SCM x) ///((name . "*") (arity . n)) { int n = 1; while (x != cell_nil) { assert (TYPE (car (x)) == TNUMBER); #if __GNUC__ n *= VALUE (car (x)); #else n = n * VALUE (car (x)); #endif x = cdr (x); } return MAKE_NUMBER (n); } SCM logior (SCM x) ///((arity . n)) { int n = 0; while (x != cell_nil) { assert (TYPE (car (x)) == TNUMBER); #if __GNUC__ n |= VALUE (car (x)); #else puts ("FIXME: logior\n"); //FIXME //n = n | VALUE (car (x)); #endif x = cdr (x); } return MAKE_NUMBER (n); } SCM ash (SCM n, SCM count) { assert (TYPE (n) == TNUMBER); assert (TYPE (count) == TNUMBER); int cn = VALUE (n); int ccount = VALUE (count); #if __GNUC__ return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount); #else //FIXME assert (ccount >= 0); return MAKE_NUMBER (cn << ccount); #endif } // Lib [rest of] SCM exit_ (SCM x) ///((name . "exit")) { assert (TYPE (x) == TNUMBER); exit (VALUE (x)); } SCM append (SCM x) ///((arity . n)) { if (x == cell_nil) return cell_nil; if (cdr (x) == cell_nil) return car (x); return append2 (car (x), append (cdr (x))); } SCM values (SCM x) ///((arity . n)) { SCM v = cons (0, x); TYPE (v) = TVALUES; return v; } SCM arity_ (SCM x) { assert (TYPE (x) == TFUNCTION); return MAKE_NUMBER (FUNCTION (x).arity); } SCM xassq (SCM x, SCM a) ///for speed in core only { while (a != cell_nil && x != CDAR (a)) a = CDR (a); return a != cell_nil ? CAR (a) : cell_f; } // Jam Collector SCM g_symbol_max; SCM gc_init_cells () ///((internal)) { //return 0; //g_cells = (scm *)malloc (ARENA_SIZE); #if __GNUC__ arena = (char*)malloc (ARENA_SIZE); #else char *p = 0; p = malloc (ARENA_SIZE); arena = p; #endif g_cells = arena; return 0; //g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm)); // #if __NYACC__ || FIXME_NYACC // TYPE (0) = TVECTOR; // // #else // // TYPE (0) = VECTOR; // #endif // LENGTH (0) = 1000; // VECTOR (0) = 0; // g_cells++; // TYPE (0) = CHAR; // VALUE (0) = 'c'; } // INIT NEWS SCM mes_symbols () ///((internal)) { gc_init_cells (); // gc_init_news (); #include "mini-mes.symbols.i" g_symbol_max = g_free; make_tmps (g_cells); g_symbols = 0; for (int i=1; i 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE"); #if __GNUC__ if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);}; #else if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs ("0.4");}; #endif g_stdin = STDIN; r0 = mes_environment (); #if MES_MINI SCM program = bload_env (r0); #else SCM program = (argc > 1 && !strcmp (argv[1], "--load")) ? bload_env (r0) : load_env (r0); if (argc > 1 && !strcmp (argv[1], "--dump")) return dump (); #endif push_cc (r2, cell_unspecified, r0, cell_unspecified); if (g_debug) { eputs ("program: "); display_ (r1); eputs ("\n"); } r3 = cell_vm_begin; r1 = eval_apply (); display_ (r1); eputs ("\n"); #if !MES_MINI gc (g_stack); #endif if (g_debug) { eputs ("\nstats: ["); eputs (itoa (g_free)); eputs ("]\n"); } return 0; } #if __GNUC__ #include "mstart.c" #endif